From 47b808190970916dcc44fcd641b7cc3c5682c3fe Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Thu, 2 Oct 2025 00:12:25 +1000 Subject: [PATCH] project_layouts --- .../basic/multishell-old.cmd | 270 - .../scriptappwrappers/basic/shellbat.bat | 112 - .../utility/scriptappwrappers/multishell2.cmd | 742 -- .../utility/scriptappwrappers/multishell3.cmd | 524 - .../utility/scriptappwrappers/multishell4.cmd | 680 - .../src/bootsupport/modules/argp-0.2.tm | 259 - .../modules/argparsingtest-0.1.0.tm | 601 - .../src/bootsupport/modules/cksum-1.1.4.tm | 200 - .../src/bootsupport/modules/cmdline-1.5.2.tm | 933 -- .../bootsupport/modules/commandstack-0.3.tm | 518 - .../src/bootsupport/modules/debug-1.0.6.tm | 306 - .../src/bootsupport/modules/dictn-0.1.2.tm | 366 - .../bootsupport/modules/dictutils-0.2.1.tm | 145 - .../src/bootsupport/modules/fauxlink-0.1.1.tm | 568 - .../src/bootsupport/modules/flagfilter-0.3.tm | 2717 ---- .../src/bootsupport/modules/funcl-0.1.tm | 325 - .../src/bootsupport/modules/http-2.10b1.tm | 5457 -------- .../src/bootsupport/modules/logger-0.9.5.tm | 1297 -- .../src/bootsupport/modules/md5-2.0.8.tm | 739 -- .../src/bootsupport/modules/metaface-1.2.5.tm | 6411 ---------- .../src/bootsupport/modules/mime-1.7.1.tm | 3934 ------ .../src/bootsupport/modules/modpod-0.1.3.tm | 709 -- .../bootsupport/modules/natsort-0.1.1.6.tm | 1962 --- .../src/bootsupport/modules/oolib-0.1.2.tm | 201 - .../src/bootsupport/modules/overtype-1.6.6.tm | 4774 ------- .../src/bootsupport/modules/pattern-1.2.4.tm | 1285 -- .../bootsupport/modules/patterncmd-1.2.4.tm | 645 - .../bootsupport/modules/patternlib-1.2.6.tm | 2590 ---- .../modules/patternpredator2-1.2.4.tm | 754 -- .../src/bootsupport/modules/promise-1.2.0.tm | 1311 -- .../src/bootsupport/modules/punk-0.1.tm | 8388 ------------- .../modules/punk/aliascore-0.1.0.tm | 346 - .../bootsupport/modules/punk/ansi-0.1.1.tm | 8727 ------------- .../modules/punk/ansi/colourmap-0.1.0.tm | 966 -- .../src/bootsupport/modules/punk/args-0.2.tm | 10325 ---------------- .../modules/punk/args/tclcore-0.1.0.tm | 6558 ---------- .../modules/punk/assertion-0.1.0.tm | 424 - .../src/bootsupport/modules/punk/cap-0.1.0.tm | 696 -- .../bootsupport/modules/punk/char-0.1.0.tm | 2841 ----- .../bootsupport/modules/punk/config-0.1.tm | 670 - .../bootsupport/modules/punk/console-0.1.1.tm | 2720 ---- .../bootsupport/modules/punk/docgen-0.1.0.tm | 87 - .../src/bootsupport/modules/punk/du-0.1.0.tm | 1641 --- .../bootsupport/modules/punk/encmime-0.1.0.tm | 437 - .../modules/punk/fileline-0.1.0.tm | 1736 --- .../src/bootsupport/modules/punk/lib-0.1.2.tm | 4556 ------- .../modules/punk/libunknown-0.1.tm | 1800 --- .../src/bootsupport/modules/punk/mix-0.2.tm | 32 - .../bootsupport/modules/punk/mix/base-0.1.tm | 993 -- .../bootsupport/modules/punk/mix/cli-0.3.1.tm | 1439 --- .../bootsupport/modules/punk/mix/cli-0.3.tm | 1128 -- .../punk/mix/commandset/buildsuite-0.1.0.tm | 152 - .../punk/mix/commandset/debug-0.1.0.tm | 92 - .../modules/punk/mix/commandset/doc-0.1.0.tm | 324 - .../punk/mix/commandset/layout-0.1.0.tm | 302 - .../punk/mix/commandset/loadedlib-0.1.0.tm | 617 - .../punk/mix/commandset/module-0.1.0.tm | 554 - .../punk/mix/commandset/project-0.1.0.tm | 1177 -- .../modules/punk/mix/commandset/repo-0.1.0.tm | 464 - .../punk/mix/commandset/scriptwrap-0.1.0.tm | 2029 --- .../modules/punk/mix/templates-0.1.0.tm | 94 - .../basic/multishell-old.cmd | 270 - .../scriptappwrappers/basic/shellbat.bat | 112 - .../utility/scriptappwrappers/multishell.cmd | 1241 +- .../utility/scriptappwrappers/multishell1.cmd | 524 - .../utility/scriptappwrappers/multishell2.cmd | 680 - .../scriptappwrappers/punk-multishell-old.cmd | 270 - .../scriptappwrappers/punk-multishell.cmd | 661 - .../scriptappwrappers/punk-multishell1.cmd | 524 - .../scriptappwrappers/punk-shellbat.bat | 112 - .../modules/punk/mix/util-0.1.0.tm | 367 - .../src/bootsupport/modules/punk/mod-0.1.tm | 161 - .../src/bootsupport/modules/punk/ns-0.1.0.tm | 4458 ------- .../bootsupport/modules/punk/overlay-0.1.tm | 193 - .../modules/punk/packagepreference-0.1.0.tm | 503 - .../bootsupport/modules/punk/path-0.1.0.tm | 1154 -- .../src/bootsupport/modules/punk/pipe-1.0.tm | 854 -- .../bootsupport/modules/punk/repl-0.1.2.tm | 3691 ------ .../modules/punk/repl/codethread-0.1.0.tm | 276 - .../bootsupport/modules/punk/repo-0.1.1.tm | 1806 --- .../src/bootsupport/modules/punk/tdl-0.1.0.tm | 109 - .../bootsupport/modules/punk/trie-0.1.0.tm | 605 - .../modules/punk/unixywindows-0.1.0.tm | 237 - .../bootsupport/modules/punk/winpath-0.1.0.tm | 363 - .../src/bootsupport/modules/punk/zip-0.1.0.tm | 761 -- .../src/bootsupport/modules/punk/zip-0.1.1.tm | 914 -- .../src/bootsupport/modules/punkapp-0.1.tm | 239 - .../bootsupport/modules/punkcheck-0.1.0.tm | 2382 ---- .../src/bootsupport/modules/sha1-2.0.4.tm | 814 -- .../bootsupport/modules/shellfilter-0.1.9.tm | 3209 ----- .../bootsupport/modules/shellfilter-0.2.tm | 3347 ----- .../src/bootsupport/modules/shellrun-0.1.1.tm | 893 -- .../bootsupport/modules/shellthread-1.6.1.tm | 829 -- .../src/bootsupport/modules/smtp-1.5.1.tm | 1508 --- .../bootsupport/modules/textblock-0.1.3.tm | 9045 -------------- .../src/bootsupport/modules/textutil-0.9.tm | 80 - .../src/bootsupport/modules/tomlish-1.1.2.tm | 5680 --------- .../src/bootsupport/modules/tomlish-1.1.3.tm | 6002 --------- .../src/bootsupport/modules/tomlish-1.1.4.tm | 6199 ---------- .../src/bootsupport/modules/tomlish-1.1.5.tm | 6973 ----------- .../src/bootsupport/modules/tomlish-1.1.6.tm | 9470 -------------- .../src/bootsupport/modules/uuid-1.0.7.tm | 245 - .../src/bootsupport/modules/uuid-1.0.8.tm | 246 - .../src/bootsupport/modules/zipper-0.12.tm | Bin 9848 -> 0 bytes .../_project/punk.project-0.1/src/make.tcl | 3628 ------ .../bootsupport/modules/fileutil-1.16.1.tm | 0 .../bootsupport/modules/fileutil/paths-1.tm | 0 .../modules/fileutil/traverse-0.6.tm | 0 .../bootsupport/modules/flagfilter-0.3.1.tm | 0 .../src/bootsupport/modules/flagfilter-0.3.tm | 2714 ---- .../src/bootsupport/modules/metaface-1.2.8.tm | 0 .../bootsupport/modules/natsort-0.1.1.6.tm | 1 + .../src/bootsupport/modules/oolib-0.1.tm | 195 - .../src/bootsupport/modules/pattern-1.2.4.tm | 1285 -- .../src/bootsupport/modules/pattern-1.2.8.tm | 0 .../src/bootsupport/modules/punk-0.1.tm | 86 +- .../bootsupport/modules/punk/ansi-0.1.1.tm | 288 +- .../src/bootsupport/modules/punk/args-0.2.tm | 51 +- .../modules/punk/args/tclcore-0.1.0.tm | 21 +- .../bootsupport/modules/punk/char-0.1.0.tm | 165 + .../bootsupport/modules/punk/console-0.1.1.tm | 667 +- .../src/bootsupport/modules/punk/lib-0.1.2.tm | 126 +- .../modules/punk/libunknown-0.1.tm | 58 +- .../bootsupport/modules/punk/mix/cli-0.3.1.tm | 242 +- .../punk/mix/commandset/module-0.1.0.tm | 31 +- .../punk/mix/commandset/project-0.1.0.tm | 21 +- .../punk/mix/commandset/scriptwrap-0.1.0.tm | 344 +- .../basic/multishell-old.cmd | 270 - .../scriptappwrappers/basic/shellbat.bat | 112 - .../utility/scriptappwrappers/multishell.cmd | 1241 +- .../utility/scriptappwrappers/multishell1.cmd | 524 - .../utility/scriptappwrappers/multishell2.cmd | 680 - .../scriptappwrappers/punk-multishell-old.cmd | 270 - .../scriptappwrappers/punk-multishell.cmd | 661 - .../scriptappwrappers/punk-multishell1.cmd | 524 - .../scriptappwrappers/punk-shellbat.bat | 112 - .../bootsupport/modules/punk/nav/fs-0.1.0.tm | 6 +- .../src/bootsupport/modules/punk/ns-0.1.0.tm | 72 +- .../bootsupport/modules/punk/path-0.1.0.tm | 68 +- .../bootsupport/modules/punk/repl-0.1.2.tm | 75 +- .../modules/punk/repl/codethread-0.1.0.tm | 276 - .../bootsupport/modules/punk/repo-0.1.1.tm | 3 + .../src/bootsupport/modules/punk/zip-0.1.1.tm | 46 +- .../bootsupport/modules/shellfilter-0.1.9.tm | 3209 ----- .../bootsupport/modules/shellfilter-0.2.tm | 40 +- .../src/bootsupport/modules/shellrun-0.1.1.tm | 5 +- .../bootsupport/modules/textblock-0.1.3.tm | 135 +- .../src/bootsupport/modules/tomlish-1.1.6.tm | 84 +- .../src/bootsupport/modules/uuid-1.0.7.tm | 245 - .../src/bootsupport/modules/uuid-1.0.8.tm | 246 - .../src/bootsupport/modules/uuid-1.0.9.tm | 0 .../src/bootsupport/modules/zipper-0.12.tm | Bin 9842 -> 9848 bytes .../src/bootsupport/modules/zzzload-0.1.0.tm | 0 .../vendor/punk/project-0.1/src/make.tcl | 1343 +- 154 files changed, 5114 insertions(+), 196713 deletions(-) delete mode 100644 src/modules/punk/mix/templates/utility/scriptappwrappers/basic/multishell-old.cmd delete mode 100644 src/modules/punk/mix/templates/utility/scriptappwrappers/basic/shellbat.bat delete mode 100644 src/modules/punk/mix/templates/utility/scriptappwrappers/multishell2.cmd delete mode 100644 src/modules/punk/mix/templates/utility/scriptappwrappers/multishell3.cmd delete mode 100644 src/modules/punk/mix/templates/utility/scriptappwrappers/multishell4.cmd delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argp-0.2.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/cksum-1.1.4.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/cmdline-1.5.2.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/debug-1.0.6.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictn-0.1.2.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictutils-0.2.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/flagfilter-0.3.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/funcl-0.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/http-2.10b1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/logger-0.9.5.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/md5-2.0.8.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/metaface-1.2.5.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/mime-1.7.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.3.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/natsort-0.1.1.6.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/oolib-0.1.2.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.6.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/pattern-1.2.4.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternlib-1.2.6.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/promise-1.2.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/assertion-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/docgen-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/encmime-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix-0.2.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/basic/multishell-old.cmd delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/basic/shellbat.bat delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/multishell1.cmd delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/multishell2.cmd delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell-old.cmd delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell.cmd delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell1.cmd delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/punk-shellbat.bat delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mod-0.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/overlay-0.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/pipe-1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/tdl-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/trie-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/unixywindows-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/winpath-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkapp-0.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/sha1-2.0.4.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.2.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellrun-0.1.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellthread-1.6.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/smtp-1.5.1.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textutil-0.9.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.2.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.3.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.4.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.5.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.6.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/uuid-1.0.7.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/uuid-1.0.8.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zipper-0.12.tm delete mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl rename src/project_layouts/{custom/_project/punk.project-0.1 => vendor/punk/project-0.1}/src/bootsupport/modules/fileutil-1.16.1.tm (100%) rename src/project_layouts/{custom/_project/punk.project-0.1 => vendor/punk/project-0.1}/src/bootsupport/modules/fileutil/paths-1.tm (100%) rename src/project_layouts/{custom/_project/punk.project-0.1 => vendor/punk/project-0.1}/src/bootsupport/modules/fileutil/traverse-0.6.tm (100%) rename src/project_layouts/{custom/_project/punk.project-0.1 => vendor/punk/project-0.1}/src/bootsupport/modules/flagfilter-0.3.1.tm (100%) delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/flagfilter-0.3.tm rename src/project_layouts/{custom/_project/punk.project-0.1 => vendor/punk/project-0.1}/src/bootsupport/modules/metaface-1.2.8.tm (100%) delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/oolib-0.1.tm delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/pattern-1.2.4.tm rename src/project_layouts/{custom/_project/punk.project-0.1 => vendor/punk/project-0.1}/src/bootsupport/modules/pattern-1.2.8.tm (100%) delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/basic/multishell-old.cmd delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/basic/shellbat.bat delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/multishell1.cmd delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/multishell2.cmd delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell-old.cmd delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell.cmd delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell1.cmd delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/punk-shellbat.bat delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/uuid-1.0.7.tm delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/uuid-1.0.8.tm rename src/project_layouts/{custom/_project/punk.project-0.1 => vendor/punk/project-0.1}/src/bootsupport/modules/uuid-1.0.9.tm (100%) rename src/project_layouts/{custom/_project/punk.project-0.1 => vendor/punk/project-0.1}/src/bootsupport/modules/zzzload-0.1.0.tm (100%) diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/basic/multishell-old.cmd b/src/modules/punk/mix/templates/utility/scriptappwrappers/basic/multishell-old.cmd deleted file mode 100644 index 1cb9e0ef..00000000 --- a/src/modules/punk/mix/templates/utility/scriptappwrappers/basic/multishell-old.cmd +++ /dev/null @@ -1,270 +0,0 @@ -set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershell;proc Hide s {proc $s args {}}; Hide :;rename set s2;Hide set;s2 1 list]"; set -- : "$@"; $1 = @' -: heredoc1 - hide from powershell (close sqote for unix shells) ' \ -: << 'HEREDOC1B_HIDE_FROM_BASH_AND_SH' -: .bat/.cmd launch section, leading colon hides from cmd, trailing slash hides next line from tcl \ -: "[Hide @ECHO; Hide ); Hide (;Hide echo]#not necessary but can help avoid errs in testing" -: Continuation char at end of this line and rem with curly-braces used to exlude Tcl from the whole cmd block \ -@REM { -@REM DO NOT MODIFY FIRST LINE OF THIS SCRIPT. shebang #! line is not required and will reduce functionality. -@REM Even comment lines can be part of the functionality of this script - modify with care. -@REM Change the value of nextshell in the next line if desired, and code within payload sections as appropriate. -@SET "nextshell=pwsh" -@REM nextshell set to pwsh,sh,bash or tclsh -@REM @ECHO nextshell is %nextshell% -@SET "validshells=pwsh,sh,bash,tclsh" -@CALL SET keyRemoved=%%validshells:%nextshell%=%% -@REM Note that 'powershell' e.g v5 is just a fallback for when pwsh is not available -@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### -@REM -- cmd/batch file section (ignored on unix) -@REM -- This section intended only to launch the next shell -@REM -- Avoid customising this if possible. cmd/batch script is probably the least expressive language. -@REM -- custom windows payloads should be in powershell,tclsh or sh/bash code sections -@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### -@SETLOCAL EnableExtensions EnableDelayedExpansion -@SET "winpath=%~dp0" -@SET "fname=%~nx0" -@REM @ECHO fname %fname% -@REM @ECHO winpath %winpath% -@IF %nextshell%==pwsh ( - CALL pwsh -nop -c set-executionpolicy -Scope CurrentUser RemoteSigned - COPY "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >NUL - REM test availability of preferred option of powershell7+ pwsh - CALL pwsh -nop -nol -c write-host "statusmessage: pwsh-found" >NUL - SET pwshtest_exitcode=!errorlevel! - REM ECHO pwshtest_exitcode !pwshtest_exitcode! - IF !pwshtest_exitcode!==0 CALL pwsh -nop -nol "%~dp0%~n0.ps1" %* & SET task_exitcode=!errorlevel! - REM fallback to powershell if pwsh failed - IF NOT !pwshtest_exitcode!==0 ( - REM CALL powershell -nop -nol -c write-host powershell-found - CALL powershell -nop -nol -file "%~dp0%~n0.ps1" %* - SET task_exitcode=!errorlevel! - ) -) ELSE ( - IF %nextshell%==bash ( - CALL :getWslPath %winpath% wslpath - REM ECHO wslfullpath "!wslpath!%fname%" - CALL %nextshell% "!wslpath!%fname%" %* & SET task_exitcode=!errorlevel! - ) ELSE ( - REM probably tclsh or sh - IF NOT "x%keyRemoved%"=="x%validshells%" ( - REM sh uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl - REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx - CALL %nextshell% "%~dp0%fname%" %* & SET task_exitcode=!errorlevel! - ) ELSE ( - ECHO %fname% has invalid nextshell value %nextshell% valid options are %validshells% - SET task_exitcode=66 - GOTO :exit - ) - ) -) -@GOTO :endlib -:getWslPath -@SETLOCAL - @SET "_path=%~p1" - @SET "name=%~nx1" - @SET "drive=%~d1" - @SET "rtrn=%~2" - @SET "result=/mnt/%drive:~0,1%%_path:\=/%%name%" -@ENDLOCAL & ( - @if "%~2" neq "" ( - SET "%rtrn%=%result%" - ) ELSE ( - ECHO %result% - ) -) -@GOTO :eof -:endlib - -: \ -@REM @SET taskexit_code=!errorlevel! & goto :exit -@GOTO :exit -# } -# rem call %nextshell% "%~dp0%~n0.cmd" %* -# -*- tcl -*- -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- tcl script section -# -- This is a punk multishell file -# -- Primary payload target is Tcl, with sh,bash,powershell as helpers -# -- but it may equally be used with any of these being the primary script. -# -- It is tuned to run when called as a batch file, a tcl script a sh/bash script or a pwsh/powershell script -# -- i.e it is a polyglot file. -# -- The specific layout including some lines that appear just as comments is quite sensitive to change. -# -- It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. -# -- e.g ./filename.polypunk.cmd in sh or bash -# -- e.g tclsh filename.cmd -# -- -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -rename set ""; rename s2 set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup -Hide :exit;Hide {<#};Hide '@ -namespace eval ::punk::multishell { - set last_script_root [file dirname [file normalize ${argv0}/__]] - set last_script [file dirname [file normalize [info script]/__]] - if {[info exists argv0] && - $last_script eq $last_script_root - } { - set ::punk::multishell::is_main($last_script) 1 ;#run as executable/script - likely desirable to launch application and return an exitcode - } else { - set ::punk::multishell::is_main($last_script) 0 ;#sourced - likely to be being used as a library - no launch, no exit. Can use return. - } - if {"::punk::multishell::is_main" ni [info commands ::punk::multishell::is_main]} { - proc ::punk::multishell::is_main {{script_name {}}} { - if {$script_name eq ""} { - set script_name [file dirname [file normalize [info script]/--]] - } - if {![info exists ::punk::multishell::is_main($script_name)]} { - #e.g a .dll or something else unanticipated - puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting" - puts stderr "Info: script_root: [file dirname [file normalize ${argv0}/__]]" - return 0 - } - return [set ::punk::multishell::is_main($script_name)] - } - } -} -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload -#puts "script : [info script]" -#puts "argcount : $::argc" -#puts "argvalues: $::argv" -#puts "argv0 : $::argv0" -# -- --- --- --- --- --- --- --- --- --- --- --- - - -# -# - - - -# -- --- --- --- --- --- --- --- --- --- --- --- -# -- Best practice is to always return or exit above, or just by leaving the below defaults in place. -# -- If the multishell script is modified to have Tcl below the Tcl Payload section, -# -- then Tcl bracket balancing needs to be carefully managed in the shell and powershell sections below. -# -- Only the # in front of the two relevant if statements below needs to be removed to enable Tcl below -# -- but the sh/bash 'then' and 'fi' would also need to be uncommented. -# -- This facility left in place for experiments on whether configuration payloads etc can be appended -# -- to tail of file - possibly binary with ctrl-z char - but utility is dependent on which other interpreters/shells -# -- can be made to ignore/cope with such data. -if {[::punk::multishell::is_main]} { - exit 0 -} else { - return -} -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload -# end hide from unix shells \ -HEREDOC1B_HIDE_FROM_BASH_AND_SH -# sh/bash \ -shift && set -- "${@:1:$#-1}" -#------------------------------------------------------ -# -- This if block only needed if Tcl didn't exit or return above. -if false==false # else { - then - : -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- sh/bash script section -# -- leave as is if all that is required is launching the Tcl payload" -# -- -# -- Note that sh/bash script isn't called when running a .bat/.cmd from cmd.exe on windows by default -# -- adjust @call line above ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate -# -- if sh/bash scripting needs to run on windows too. -# -- -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload -#printf "start of bash or sh code" - -# -# - -# -- --- --- --- --- --- --- --- -# -exitcode=0 ;#default assumption -#-- sh/bash launches Tcl here instead of shebang line at top -#-- use exec to use exitcode (if any) directly from the tcl script -#exec /usr/bin/env tclsh "$0" "$@" -#-- alternative - can run sh/bash script after the tcl call. -/usr/bin/env tclsh "$0" "$@" -exitcode=$? -#echo "tcl exitcode: ${exitcode}" -#-- override exitcode example -#exit 66 -# -# -- --- --- --- --- --- --- --- - -# -# - - -#printf "sh/bash done \n" -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end sh Payload -#------------------------------------------------------ -fi -exit ${exitcode} -# end hide sh/bash block from Tcl -# This comment with closing brace should stay in place whether if commented or not } -#------------------------------------------------------ -# begin hide powershell-block from Tcl - only needed if Tcl didn't exit or return above -if 0 { -: end heredoc1 - end hide from powershell \ -'@ -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- powershell/pwsh section -# -- -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -function GetScriptName { $myInvocation.ScriptName } -$scriptname = getScriptName -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload -#"Timestamp : {0,10:yyyy-MM-dd HH:mm:ss}" -f $(Get-Date) | write-host -#"Script Name : {0}" -f $scriptname | write-host -#"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host -#"powershell args : {0}" -f ($args -join ", ") | write-host -# -- --- --- --- - -# -# - - -# -- --- --- --- --- --- --- --- -# -tclsh $scriptname $args -# -# -- --- --- --- --- --- --- --- - - -# -# - -# unbal } - -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload -#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host -Exit $LASTEXITCODE -# heredoc2 for powershell to ignore block below -$1 = @' -' -: end hide powershell-block from Tcl \ -# This comment with closing brace should stay in place whether 'if' commented or not } -: cmd exit label - return exitcode -:exit -: \ -@REM @ECHO exitcode: !task_exitcode! -: \ -@EXIT /B !task_exitcode! -# cmd has exited -: end heredoc2 \ -'@ -<# -# id:tailblock0 -# -- powershell multiline comment -#> -<# -# id:tailblock1 -# - -# -# -- unreachable by tcl directly if ctrl-z character is in the section above. (but file can be read and split on \x1A) -# -- Potential for zip and/or base64 contents, but we can't stop pwsh parser from slurping in the data -# -- so for example a plain text tar archive could cause problems depending on the content. -# -- final line in file must be the powershell multiline comment terminator or other data it can handle. -# -- e.g plain # comment lines will work too -# -- (for example a powershell digital signature is a # commented block of data at the end of the file) -#> - - diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/basic/shellbat.bat b/src/modules/punk/mix/templates/utility/scriptappwrappers/basic/shellbat.bat deleted file mode 100644 index aa9039a9..00000000 --- a/src/modules/punk/mix/templates/utility/scriptappwrappers/basic/shellbat.bat +++ /dev/null @@ -1,112 +0,0 @@ -: "[proc : args {}]" ;# *tcl shellbat - call with sh,bash,tclsh on any platform, or with cmd on windows. -: <<'HIDE_FROM_BASH_AND_SH' -: ;# leading colon hides from .bat, trailing slash hides next line from tcl \ -@call tclsh "%~dp0%~n0.bat" %* -: ;#\ -@set taskexitcode=%errorlevel% & goto :exit -# -*- tcl -*- -# ################################################################################################# -# This is a tcl shellbat file -# It is tuned to run when called as a batch file, a tcl script, an sh script or a bash script, -# so the specific layout and characters used are quite sensitive to change. -# It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. -# e.g ./filename.sh.bat in sh or bash or powershell -# e.g filename.sh or filename.sh.bat at windows command prompt -# e.g tclsh filename.sh.bat | sh filename.sh.bat | bash filename.sh.bat -# In all cases an arbitrary number of arguments are accepted -# To avoid the initial commandline on stdout when calling as a batch file on windows, use: -# cmd /Q /c filename.sh.bat -# (because we cannot use @if to silence it, as this isn't understood by tcl,sh or bash) -# ################################################################################################# -#fconfigure stdout -translation crlf -# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload -#puts "script : [info script]" -#puts "argcount : $::argc" -#puts "argvalues: $::argv" - - -# -# - -# --- --- --- --- --- --- --- --- --- --- --- --- --- -# only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods -# --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload -#-- -#-- bash/sh code follows. -#-- protect from tcl using line continuation char on the previous comment for each line, like so: \ -printf "etc" -#-- or alternatively place sh/bash script within the false==false block -#-- whilst being careful to balance braces {} -#-- For more complex needs you should call out to external scripts -#-- -#-- END marker for hide_from_bash_and_sh\ -HIDE_FROM_BASH_AND_SH - -#--------------------------------------------------------- -#-- This if statement hides(mostly) a sh/bash code block from Tcl -if false==false # else { -then -: -#--------------------------------------------------------- - #-- leave as is if all that's required is launching the Tcl payload" - #-- - #-- Note that sh/bash script isn't called when running a .bat from cmd.exe on windows by default - #-- adjust line 4: @call tclsh ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate - #-- if sh/bash scripting needs to run on windows too. - #-- - #printf "start of bash or sh code" - - # - # - - - #-- sh/bash launches Tcl here instead of shebang line at top - # - #-- use exec to use exitcode (if any) directly from the tcl script - exec /usr/bin/env tclsh "$0" "$@" - # - - #-- alternative - if sh/bash script required to run after the tcl call. - #/usr/bin/env tclsh "$0" "$@" - #tcl_exitcode=$? - #echo "tcl_exitcode: ${tcl_exitcode}" - - # - # - - #-- override exitcode example - #exit 66 - - #printf "No need for trailing slashes for sh/bash code here\n" -#--------------------------------------------------------- -fi -# closing brace for Tcl } -#--------------------------------------------------------- - -#-- tcl and shell script now both active - -#-- comment for line sample 1 with trailing continuation slash \ -#printf "tcl-invisible sh/bash line sample 1 \n" - -#-- comment for line sample 2 with trailing continuation slash \ -#printf "tcl-invisible sh/bash line sample 2 \n" - - -#-- Consistent exitcode from sh,bash,tclsh or cmd -#-- Call exit in tcl (or sh/bash) code only if explicitly required, otherwise leave this commented out. -#-- (script might be more widely useable without explicit exit. e.g in tcl: set ::argc 1; set ::argv "val"; source filename.sh.bat ) -#-- exit line unprotected by trailing slash will work for tcl and/or sh/bash -#exit 0 -#exit 42 - - - -#-- make sure sh/bash/tcl all skip over .bat style exit \ -: <<'shell_end' -#-- .bat exit with exitcode from tcl process \ -:exit -: ;# \ -@exit /B %taskexitcode% -# .bat has exited \ -shell_end - diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell2.cmd b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell2.cmd deleted file mode 100644 index 9daf7ebf..00000000 --- a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell2.cmd +++ /dev/null @@ -1,742 +0,0 @@ -: "punk MULTISHELL - shebangless polyglot for Tcl Perl sh bash cmd pwsh powershell" + "[rename set s;proc Hide x {proc $x args {}};Hide :]" + "\$(function : {<#pwsh#>})" + "perlhide" + qw^ -set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' -: heredoc1 - hide from powershell using @ and squote above. close sqote for unix shells + ' \ -: .bat/.cmd launch section, leading colon hides from cmd, trailing slash hides next line from tcl + \ -: "[Hide @GOTO; Hide =begin; Hide @REM] #not necessary but can help avoid errs in testing" + -: << 'HEREDOC1B_HIDE_FROM_BASH_AND_SH' -: STRONG SUGGESTION: DO NOT MODIFY FIRST LINE OF THIS SCRIPT - except for first double quoted section. -: shebang line is not required on unix or windows and will reduce functionality and/or portability. -: Even comment lines can be part of the functionality of this script (both on unix and windows) - modify with care. -@GOTO :skip_perl_pod_start ^; -=begin excludeperl -: skip_perl_pod_start -: Continuation char at end of this line and rem with curly-braces used to exlude Tcl from the whole cmd block \ -: { -@REM ############################################################################################################################ -@REM THIS IS A POLYGLOT SCRIPT - supporting payloads in Tcl, bash, (some sh) and/or powershelll (powershell.exe or pwsh.exe) -@REM It should remain portable between unix-like OSes & windows if the proper structure is maintained. -@REM ############################################################################################################################ -@REM On windows, change the value of nextshell to one of the listed 2 digit values if desired, and add code within payload sections for tcl,sh,bash,powershell as appropriate. -@REM This wrapper can be edited manually (carefully!) - or sh,bash,tcl,powershell scripts can be wrapped using the Tcl-based punkshell system -@REM e.g from within a running punkshell: deck scriptwrap.multishell -outputfolder -@REM On unix-like systems, call with sh, bash or tclsh. (powershell untested on unix - and requires wscript if security elevation is used) -@REM Due to lack of shebang (#! line) Unix-like systems will probably (hopefully) default to sh if the script is called without an interpreter - but it may depend on the shell in use when called. -@REM If you find yourself really wanting/needing to add a shebang line - do so on the basis that the script will exist on unix-like systems only. -@REM in batch scripts - array syntax with square brackets is a simulation of arrays or associative arrays. -@REM note that many shells linked as sh do not support substition syntax and may fail - e.g dash etc - generally bash should be used in this context -@SETLOCAL EnableExtensions EnableDelayedExpansion -@SET "validshelltypes= powershell______ sh______________ wslbash_________ bash____________ tcl_____________ perl____________" -@REM for batch - only win32 is relevant - but other scripts on other platforms also parse the nextshell block to determine next shell to launch -@REM nextshellpath and nextshelltype indices (underscore-padded to 16wide) are "other" plus those returned by Tcl platform pkg e.g win32,linux,freebsd,macosx -@REM The horrible underscore-padded fixed-widths are to keep the batch labels aligned whilst allowing values to be set -@REM If more than 32 chars needed for a target, it can still be done but overall script padding may need checking/adjusting -@REM Supporting more explicit oses than those listed may also require script padding adjustment -: -@SET "nextshellpath[win32___________]=tclsh___________________________" -@SET "nextshelltype[win32___________]=tcl_____________" -@SET "nextshellpath[dragonflybsd____]=/usr/bin/env tclsh______________" -@SET "nextshelltype[dragonflybsd____]=tcl_____________" -@SET "nextshellpath[freebsd_________]=/usr/bin/env tclsh______________" -@SET "nextshelltype[freebsd_________]=tcl_____________" -@SET "nextshellpath[netbsd__________]=/usr/bin/env tclsh______________" -@SET "nextshelltype[netbsd__________]=tcl_____________" -@SET "nextshellpath[linux___________]=/usr/bin/env tclsh______________" -@SET "nextshelltype[linux___________]=tcl_____________" -@SET "nextshellpath[macosx__________]=/usr/bin/env tclsh______________" -@SET "nextshelltype[macosx__________]=tcl_____________" -@SET "nextshellpath[other___________]=/usr/bin/env tclsh______________" -@SET "nextshelltype[other___________]=tcl_____________" -: -@rem asadmin is for automatic elevation to administrator. Separate window will be created (seems unavoidable with current elevation mechanism) and user will still get security prompt (probably reasonable). -: -@SET "asadmin=0" -: -@REM @ECHO nextshelltype is %nextshelltype[win32___________]% -@REM @SET "selected_shelltype=%nextshelltype[win32___________]%" -@SET "selected_shelltype=%nextshelltype[win32___________]%" -@REM @ECHO selected_shelltype %selected_shelltype% -@CALL :stringTrimTrailingUnderscores %selected_shelltype% selected_shelltype_trimmed -@REM @ECHO selected_shelltype_trimmed %selected_shelltype_trimmed% -@SET "selected_shellpath=%nextshellpath[win32___________]%" -@CALL :stringTrimTrailingUnderscores %selected_shellpath% selected_shellpath_trimmed -@CALL SET "keyRemoved=%%validshelltypes:!selected_shelltype!=%%" -@REM @ECHO keyremoved %keyRemoved% -@REM Note that 'powershell' e.g v5 is just a fallback for when pwsh is not available -@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### -@REM -- cmd/batch file section (ignored on unix but should be left in place) -@REM -- This section intended mainly to launch the next shell (and to escalate privileges if necessary) -@REM -- Avoid customising this if you are not familiar with batch scripting. cmd/batch script can be useful, but is probably the least expressive language and most error prone. -@REM -- For example - as this file needs to use unix-style lf line-endings - the label scanner is susceptible to the 512Byte boundary issue: https://www.dostips.com/forum/viewtopic.php?t=8988#p58888 -@REM -- This label issue can be triggered/abused in files with crlf line endings too - but it is less likely to happen accidentaly. -@REm -- See also: https://stackoverflow.com/questions/4094699/how-does-the-windows-command-interpreter-cmd-exe-parse-scripts/4095133#4095133 -@REM ############################################################################################################################ -@REM -- Due to this issue -seemingly trivial edits of the batch file section can break the script! (for Windows anyway) -@REM -- Even something as simple as adding or removing an @REM -@REM -- From within punkshell - use: -@REM -- deck scriptwrap.checkfile -@REM -- to check your templates or final wrapped scripts for byte boundary issues -@REM -- It will report any labels that are on boundaries -@REM -- This is why the nextshell value above is a 2 digit key instead of a string - so that editing the value doesn't change the byte offsets. -@REM -- Editing your sh,bash,tcl,pwsh payloads is much less likely to cause an issue. There is the possibility of the final batch :exit_multishell label spanning a boundary - so testing using deck scriptwrap.checkfile is still recommended. -@REM -- Alternatively, as you should do anyway - test the final script on windows -@REM -- Aside from adding comments/whitespace to tweak the location of labels - you can try duplicating the label (e.g just add the label on a line above) but this is not guaranteed to work in all situations. -@REM -- '@REM' is a safer comment mechanism than a leading colon - which is used sparingly here. -@REM -- A colon anywhere in the script that happens to land on a 512 Byte boundary (from file start or from a callsite) could be misinterpreted as a label -@REM -- It is unknown what versions of cmd interpreters behave this way - and deck scriptwrap.checkfile doesn't check all such boundaries. -@REm -- For this reason, batch labels should be chosen to be relatively unlikely to collide with other strings in the file, and simple names such as :exit or :end should probably be avoided -@REM ############################################################################################################################ -@REM -- custom windows payloads should be in powershell,tclsh (or sh/bash if available) code sections -@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### -@SET "winpath=%~dp0" -@SET "fname=%~nx0" -@REM @ECHO fname %fname% -@REM @ECHO winpath %winpath% -@REM @ECHO commandlineascalled %0 -@REM @ECHO commandlineresolved %~f0 -@CALL :getNormalizedScriptTail nftail -@REM @ECHO normalizedscripttail %nftail% -@CALL :getFileTail %0 clinetail -@REM @ECHO clinetail %clinetail% -@CALL :stringToUpper %~nx0 capscripttail -@REM @ECHO capscriptname: %capscripttail% - -@IF "%nftail%"=="%capscripttail%" ( - @ECHO forcing asadmin=1 due to file name on filesystem being uppercase - @SET "asadmin=1" -) else ( - @CALL :stringToUpper %clinetail% capcmdlinetail - @REM @ECHO capcmdlinetail !capcmdlinetail! - IF "%clinetail%"=="!capcmdlinetail!" ( - @ECHO forcing asadmin=1 due to cmdline scriptname in uppercase - @set "asadmin=1" - ) -) -@SET "vbsGetPrivileges=%temp%\punk_bat_elevate_%fname%.vbs" -@SET arglist=%* -@SET "qstrippedargs=args%arglist%" -@SET "qstrippedargs=%qstrippedargs:"=%" -@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" ( - GOTO :gotPrivileges -) -@IF !asadmin!==1 ( - net file 1>NUL 2>NUL - @IF '!errorlevel!'=='0' ( GOTO :gotPrivileges ) else ( GOTO :getPrivileges ) -) -@REM padding -@REM padding -@REM padding -@REM padding -@REM padding -@REM padding -@REM padding -@REM padding -@REM padding -@REM padding -@REM padding -@REM padding -@GOTO skip_privileges -:getPrivileges -@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (echo PUNK-ELEVATED & shift /1 & goto :gotPrivileges ) -@ECHO Set UAC = CreateObject^("Shell.Application"^) > "%vbsGetPrivileges%" -@ECHO args = "PUNK-ELEVATED " >> "%vbsGetPrivileges%" -@ECHO For Each strArg in WScript.Arguments >> "%vbsGetPrivileges%" -@ECHO args = args ^& strArg ^& " " >> "%vbsGetPrivileges%" -@ECHO Next >> "%vbsGetPrivileges%" -@ECHO UAC.ShellExecute "%~dp0%~n0%~x0", args, "", "runas", 1 >> "%vbsGetPrivileges%" -@ECHO Launching script in new windows due to administrator elevation -@"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" %* -@EXIT /B - -:gotPrivileges -@REM setlocal & pushd . -@PUSHD . -@cd /d %~dp0 -@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" ( - @DEL "%vbsGetPrivileges%" 1>nul 2>nul - @SET arglist=%arglist:~14% -) - -:skip_privileges -@SET need_ps1=0 -@REM we want the ps1 to exist even if the nextshell isn't powershell -@if not exist "%~dp0%~n0.ps1" ( - @SET need_ps1=1 -) ELSE ( - fc "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >nul || goto different - @REM @ECHO "files same" - @SET need_ps1=0 -) -@GOTO :pscontinue -:different -@REM @ECHO "files differ" -@SET need_ps1=1 -:pscontinue -@IF !need_ps1!==1 ( - COPY "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >NUL -) -@REM avoid using CALL to launch pwsh,tclsh etc - it will intercept some args such as /? -@IF "%selected_shelltype_trimmed%"=="powershell" ( - REM pws vs powershell hasn't been tested because we didn't need to copy cmd to ps1 this time - REM test availability of preferred option of powershell7+ pwsh - pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; write-host "statusmessage: pwsh-found" >NUL - SET pwshtest_exitcode=!errorlevel! - REM ECHO pwshtest_exitcode !pwshtest_exitcode! - REM fallback to powershell if pwsh failed - IF !pwshtest_exitcode!==0 ( - pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%~dp0%~n0.ps1" %arglist% - SET task_exitcode=!errorlevel! - ) ELSE ( - REM CALL powershell -nop -nol -c write-host powershell-found - REM powershell -nop -nol -file "%~dp0%~n0.ps1" %* - powershell -nop -nol -c set-executionpolicy -Scope Process Unrestricted; %~dp0%~n0.ps1" %arglist% - SET task_exitcode=!errorlevel! - ) -) ELSE ( - IF "%selected_shelltype_trimmed%"=="wslbash" ( - CALL :getWslPath %winpath% wslpath - REM ECHO wslfullpath "!wslpath!%fname%" - %selected_shellpath_trimmed% "!wslpath!%fname%" %arglist% - SET task_exitcode=!errorlevel! - ) ELSE ( - REM perl or tcl or sh or bash - IF NOT "x%keyRemoved%"=="x%validshelltypes%" ( - REM sh on windows uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl - REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx - REM The compound statement with trailing call is required to stop batch termination confirmation, whilst still capturing exitcode - %selected_shellpath_trimmed% "%~dp0%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call; - ) ELSE ( - ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes% - SET task_exitcode=66 - @REM boundary padding - @REM boundary padding - @REM boundary padding - @REM boundary padding - GOTO :exit_multishell - ) - ) -) -@REM batch file library functions -@REM boundary padding -@GOTO :endlib - -:getWslPath -@SETLOCAL - @SET "_path=%~p1" - @SET "name=%~nx1" - @SET "drive=%~d1" - @SET "rtrn=%~2" - @REM Although drive letters on windows are normally upper case wslbash seems to expect lower case drive letters - @CALL :stringToLower %drive ldrive - @SET "result=/mnt/%ldrive:~0,1%%_path:\=/%%name%" -@ENDLOCAL & ( - @if "%~2" neq "" ( - SET "%rtrn%=%result%" - ) ELSE ( - ECHO %result% - ) -) -@EXIT /B - -:getFileTail -@REM return tail of file without any normalization e.g c:/punkshell/bin/Punk.cmd returns Punk.cmd even if file is punk.cmd -@REM we can't use things such as %~nx1 as it can change capitalisation -@REM This function is designed explicitly to preserve capitalisation -@REM accepts full paths with either / or \ as delimiters - or -@SETLOCAL - @SET "rtrn=%~2" - @SET "arg=%~1" - @REM @SET "result=%_arg:*/=%" - @REM @SET "result=%~1" - @SET LF=^ - - - : The above 2 empty lines are important. Don't remove - @CALL :stringContains "!arg!" "\" hasBackSlash - @IF "!hasBackslash!"=="true" ( - @for %%A in ("!LF!") do @( - @FOR /F %%B in ("!arg:\=%%~A!") do @set "result=%%B" - ) - ) ELSE ( - @CALL :stringContains "!arg!" "/" hasForwardSlash - @IF "!hasForwardSlash!"=="true" ( - @FOR %%A in ("!LF!") do @( - @FOR /F %%B in ("!arg:/=%%~A!") do @set "result=%%B" - ) - ) ELSE ( - @set "result=%arg%" - ) - ) -@ENDLOCAL & ( - @if "%~2" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO %result% - ) -) -@EXIT /B -@REM boundary padding -@REM boundary padding -:getNormalizedScriptTail -@SETLOCAL - @SET "result=%~nx0" - @SET "rtrn=%~1" -@ENDLOCAL & ( - @IF "%~1" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO %result% - ) -) -@EXIT /B - -:getNormalizedFileTailFromPath -@REM warn via echo, and do not set return variable if path not found -@REM note that %~nx1 does not preserve case of provided path - hence the name 'normalized' -@REM boundary padding -@REM boundary padding -@REM boundary padding -@REM boundary padding -@SETLOCAL - @CALL :stringContains %~1 "\" hasBackSlash - @CALL :stringContains %~1 "/" hasForwardSlash - @IF "%hasBackslash%-%hasForwardslash%"=="false-false" ( - @SET "P=%cd%%~1" - @CALL :getNormalizedFileTailFromPath "!P!" ftail2 - @SET "result=!ftail2!" - ) else ( - @IF EXIST "%~1" ( - @SET "result=%~nx1" - ) else ( - @ECHO error getNormalizedFileTailFromPath file not found: %~1 - @EXIT /B 1 - ) - ) - @SET "rtrn=%~2" -@ENDLOCAL & ( - @IF "%~2" neq "" ( - SET "%rtrn%=%result%" - ) ELSE ( - @ECHO getNormalizedFileTailFromPath %1 result: %result% - ) -) -@EXIT /B - -:stringContains -@REM usage: @CALL:stringContains string needle returnvarname -@SETLOCAL - @SET "rtrn=%~3" - @SET "string=%~1" - @SET "needle=%~2" - @IF "!string:%needle%=!"=="!string!" @( - @SET "result=false" - ) ELSE ( - @SET "result=true" - ) -@ENDLOCAL & ( - @IF "%~3" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO stringContains %string% %needle% result: %result% - ) -) -@EXIT /B -@REM boundary padding -@REM boundary padding -:stringToUpper -@SETLOCAL - @SET "rtrn=%~2" - @SET "string=%~1" - @SET "capstring=%~1" - @FOR %%A in (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z) DO @( - @SET "capstring=!capstring:%%A=%%A!" - ) - @SET "result=!capstring!" -@ENDLOCAL & ( - @IF "%~2" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO stringToUpper %string% result: %result% - ) -) -@EXIT /B -:stringToLower -@SETLOCAL - @SET "rtrn=%~2" - @SET "string=%~1" - @SET "retstring=%~1" - @FOR %%A in (a b c d e f g h i j k l m n o p q r s t u v w x y z) DO @( - @SET "retstring=!retstring:%%A=%%A!" - ) - @SET "result=!retstring!" -@ENDLOCAL & ( - @IF "%~2" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO stringToLower %string% result: %result% - ) -) -@EXIT /B -@REM boundary padding -@REM boundary padding -:stringTrimTrailingUnderscores -@SETLOCAL - @SET "rtrn=%~2" - @SET "string=%~1" - @SET "trimstring=%~1" - @REM trim up to 31 underscores from the end of a string using string substitution - @SET trimstring=%trimstring%### - @SET trimstring=%trimstring:________________###=###% - @SET trimstring=%trimstring:________###=###% - @SET trimstring=%trimstring:____###=###% - @SET trimstring=%trimstring:__###=###% - @SET trimstring=%trimstring:_###=###% - @SET trimstring=%trimstring:###=% - @SET "result=!trimstring!" -@ENDLOCAL & ( - @IF "%~2" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO stringTrimTrailingUnderscores %string% result: %result% - ) -) -@EXIT /B -:isNumeric -@SETLOCAL - @SET "notnumeric="&FOR /F "delims=0123456789" %%i in ("%1") do set "notnumeric=%%i" - @IF defined notnumeric ( - @SET "result=false" - ) else ( - @SET "result=true" - ) - @SET "rtrn=%~2" -@ENDLOCAL & ( - @IF "%~2" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO %result% - ) -) -@EXIT /B - -:endlib -: \ -@REM padding -@REM padding -@REM @SET taskexit_code=!errorlevel! & goto :exit_multishell -@GOTO :exit_multishell -# } -# -*- tcl -*- -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- tcl script section -# -- This is a punk multishell file -# -- Primary payload target is Tcl, with sh,bash,powershell as helpers -# -- but it may equally be used with any of these being the primary script. -# -- It is tuned to run when called as a batch file, a tcl script a sh/bash script or a pwsh/powershell script -# -- i.e it is a polyglot file. -# -- The specific layout including some lines that appear just as comments is quite sensitive to change. -# -- It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. -# -- e.g ./filename.polypunk.cmd in sh or bash -# -- e.g tclsh filename.cmd -# -- -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -rename set ""; rename s set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore -Hide :exit_multishell;Hide {<#};Hide '@ -namespace eval ::punk::multishell { - set last_script_root [file dirname [file normalize ${::argv0}/__]] - set last_script [file dirname [file normalize [info script]/__]] - if {[info exists ::argv0] && - $last_script eq $last_script_root - } { - set ::punk::multishell::is_main($last_script) 1 ;#run as executable/script - likely desirable to launch application and return an exitcode - } else { - set ::punk::multishell::is_main($last_script) 0 ;#sourced - likely to be being used as a library - no launch, no exit. Can use return. - } - if {"::punk::multishell::is_main" ni [info commands ::punk::multishell::is_main]} { - proc ::punk::multishell::is_main {{script_name {}}} { - if {$script_name eq ""} { - set script_name [file dirname [file normalize [info script]/--]] - } - if {![info exists ::punk::multishell::is_main($script_name)]} { - #e.g a .dll or something else unanticipated - puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting" - puts stderr "Info: script_root: [file dirname [file normalize ${::argv0}/__]]" - return 0 - } - return [set ::punk::multishell::is_main($script_name)] - } - } -} -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload -#puts "script : [info script]" -#puts "argcount : $::argc" -#puts "argvalues: $::argv" -#puts "argv0 : $::argv0" -# -- --- --- --- --- --- --- --- --- --- --- --- - - -# -# - -# -# - - -# -# - - -# -- --- --- --- --- --- --- --- --- --- --- --- -# -- Best practice is to always return or exit above, or just by leaving the below defaults in place. -# -- If the multishell script is modified to have Tcl below the Tcl Payload section, -# -- then Tcl bracket balancing needs to be carefully managed in the shell and powershell sections below. -# -- Only the # in front of the two relevant if statements below needs to be removed to enable Tcl below -# -- but the sh/bash 'then' and 'fi' would also need to be uncommented. -# -- This facility left in place for experiments on whether configuration payloads etc can be appended -# -- to tail of file - possibly binary with ctrl-z char - but utility is dependent on which other interpreters/shells -# -- can be made to ignore/cope with such data. -if {[::punk::multishell::is_main]} { - exit 0 -} else { - return -} -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload -# end hide from unix shells \ -HEREDOC1B_HIDE_FROM_BASH_AND_SH -# sh/bash \ -shift && set -- "${@:1:$#-1}" -#------------------------------------------------------ -# -- This if block only needed if Tcl didn't exit or return above. -if false==false # else { - then - : # -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- sh/bash script section -# -- leave as is if all that is required is launching the Tcl payload" -# -- -# -- Note that sh/bash script isn't called when running a .bat/.cmd from cmd.exe on windows by default -# -- adjust the %nextshell% value above -# -- if sh/bash scripting needs to run on windows too. -# -- -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload -exitcode=0 -#printf "start of bash or sh code" - -# -# - -# -- --- --- --- --- --- --- --- -# -#-- sh/bash launches Tcl here instead of shebang line at top -#-- use exec to use exitcode (if any) directly from the tcl script -#exec /usr/bin/env tclsh "$0" "$@" -#-- alternative - can run sh/bash script after the tcl call. -/usr/bin/env tclsh "$0" "$@" -exitcode=$? -#echo "sh/bash reporting tcl exitcode: ${exitcode}" -#-- override exitcode example -#exit 66 -# -# -- --- --- --- --- --- --- --- - -# -# - - -#printf "sh/bash done \n" -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end sh Payload -#------------------------------------------------------ -fi -exit ${exitcode} -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- Perl script section -# -- leave the script below as is, if all that is required is launching the Tcl payload" -# -- -# -- Note that perl script isn't called by default when simply running this script by name -# -- adjust the nextshell value at the top of the script to point to perl -# -- -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -=cut -#!/user/bin/perl -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin perl Payload -my $exit_code = 0; -#use ExtUtils::Installed; -#my $installed = ExtUtils::Installed->new(); -#my @modules = $installed->modules(); -#print "Modules:\n"; -#foreach my $m (@modules) { -# print "$m\n"; -#} -# -- --- --- - - - -my $scriptname = $0; -print "perl $scriptname\n"; -my $i =1; -foreach my $a(@ARGV) { - print "Arg # $i: $a\n"; -} - -# -# - - - -# -- --- --- --- --- --- --- --- -# -$exit_code=system("tclsh", $scriptname, @ARGV); -#print "perl reporting tcl exitcode: $exit_code"; -# -# -- --- --- --- --- --- --- --- - -# -# - - -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end perl Payload -exit $exit_code; -__END__ - -# end hide sh/bash/perl block from Tcl -# This comment with closing brace should stay in place whether if commented or not } -#------------------------------------------------------ -# begin hide powershell-block from Tcl - only needed if Tcl didn't exit or return above -if 0 { -: end heredoc1 - end hide from powershell \ -'@ -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- powershell/pwsh section -# -- Do not edit if current file is the .ps1 -# -- Edit the corresponding .cmd and it will autocopy -# -- unbalanced braces { } here *even in comments* will cause problems if there was no Tcl exit or return above -# -- custom script should generally go below the begin_powershell_payload line -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -function GetScriptName { $myInvocation.ScriptName } -$scriptname = GetScriptName -function GetDynamicParamDictionary { - [CmdletBinding()] - param( - [Parameter(ValueFromPipeline=$true, Mandatory=$true)] - [string] $CommandName - ) - - begin { - # Get a list of params that should be ignored (they're common to all advanced functions) - $CommonParameterNames = [System.Runtime.Serialization.FormatterServices]::GetUninitializedObject([type] [System.Management.Automation.Internal.CommonParameters]) | - Get-Member -MemberType Properties | - Select-Object -ExpandProperty Name - } - - process { - # Create the dictionary that this scriptblock will return: - $DynParamDictionary = New-Object System.Management.Automation.RuntimeDefinedParameterDictionary - - # Convert to object array and get rid of Common params: - (Get-Command $CommandName | select -exp Parameters).GetEnumerator() | - Where-Object { $CommonParameterNames -notcontains $_.Key } | - ForEach-Object { - $DynamicParameter = New-Object System.Management.Automation.RuntimeDefinedParameter ( - $_.Key, - $_.Value.ParameterType, - $_.Value.Attributes - ) - $DynParamDictionary.Add($_.Key, $DynamicParameter) - } - - # Return the dynamic parameters - return $DynParamDictionary - } -} -# GetDynamicParamDictionary -# - This can make it easier to share a single set of param definitions between functions -# - sample usage -#function ParameterDefinitions { -# param( -# [Parameter(Mandatory)][string] $myargument -# ) -#} -#function psmain { -# [CmdletBinding()] -# param() -# dynamicparam { GetDynamicParamDictionary ParameterDefinitions } -# process { -# #called once with $PSBoundParameters dictionary -# #can be used to validate arguments, or set a simpler variable name for access -# switch ($PSBoundParameters.keys) { -# 'myargumentname' { -# Set-Variable -Name $_ -Value $PSBoundParameters."$_" -# } -# #... -# } -# foreach ($boundparam in $PSBoundParameters.GetEnumerator()) { -# #... -# } -# } -# end { -# #Main function logic -# Write-Host "myargumentname value is: $myargumentname" -# #myotherfunction @PSBoundParameters -# } -#} -#psmain @args -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload -#"Timestamp : {0,10:yyyy-MM-dd HH:mm:ss}" -f $(Get-Date) | write-host -#"Script Name : {0}" -f $scriptname | write-host -#"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host -#"powershell args : {0}" -f ($args -join ", ") | write-host -# -- --- --- --- - -# -# - - -# -- --- --- --- --- --- --- --- -# -tclsh $scriptname $args -#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host -# -# -- --- --- --- --- --- --- --- - - -# -# - -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload -Exit $LASTEXITCODE -# heredoc2 for powershell to ignore block below -$1 = @' -' -: comment end hide powershell-block from Tcl \ -# This comment with closing brace should stay in place whether 'if' commented or not } -: multishell doubled-up cmd exit label - return exitcode -:exit_multishell -:exit_multishell -: \ -@REM @ECHO exitcode: !task_exitcode! -: \ -@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit) -: \ -@EXIT /B !task_exitcode! -# cmd has exited -: comment end heredoc2 \ -'@ -<# -# id:tailblock0 -# -- powershell multiline comment -#> -<# -no script engine should try to run me -# id:tailblock1 -# - -# -# -- unreachable by tcl directly if ctrl-z character is in the section above. (but file can be read and split on \x1A) -# -- Potential for zip and/or base64 contents, but we can't stop pwsh parser from slurping in the data -# -- so for example a plain text tar archive could cause problems depending on the content. -# -- final line in file must be the powershell multiline comment terminator or other data it can handle. -# -- e.g plain # comment lines will work too -# -- (for example a powershell digital signature is a # commented block of data at the end of the file) -#> - - diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell3.cmd b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell3.cmd deleted file mode 100644 index 17fe4c15..00000000 --- a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell3.cmd +++ /dev/null @@ -1,524 +0,0 @@ -: "[rename set s;proc Hide x {proc $x args {}};Hide :]" "\$(function : {<#pwsh#>})" ^ -set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershell;proc Hide x {proc $x args {}}; Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' -: heredoc1 - hide from powershell using @ and squote above. (close sqote for unix shells) ' \ -: .bat/.cmd launch section, leading colon hides from cmd, trailing slash hides next line from tcl \ -: "[Hide @ECHO; Hide ); Hide (;Hide echo; Hide @REM]#not necessary but can help avoid errs in testing" -: << 'HEREDOC1B_HIDE_FROM_BASH_AND_SH' -: Continuation char at end of this line and rem with curly-braces used to exlude Tcl from the whole cmd block \ -: { -: STRONG SUGGESTION: DO NOT MODIFY FIRST LINE OF THIS SCRIPT. shebang #! line is not required on unix or windows and will reduce functionality and/or portability. -: Even comment lines can be part of the functionality of this script (both on unix and windows) - modify with care. -@REM ############################################################################################################################ -@REM THIS IS A POLYGLOT SCRIPT - supporting payloads in Tcl, bash, sh and/or powershelll (powershell.exe or pwsh.exe) -@REM It should remain portable between unix-like OSes & windows if the proper structure is maintained. -@REM ############################################################################################################################ -@REM On windows, change the value of nextshell to one of the listed 2 digit values if desired, and add code within payload sections for tcl,sh,bash,powershell as appropriate. -@REM This wrapper can be edited manually (carefully!) - or sh,bash,tcl,powershell scripts can be wrapped using the Tcl-based punkshell system -@REM e.g from within a running punkshell: pmix scriptwrap.multishell -outputfolder -@REM On unix-like systems, call with sh, bash or tclsh. (powershell untested on unix - and requires wscript if security elevation is used) -@REM Due to lack of shebang (#! line) Unix-like systems will probably (hopefully) default to sh if the script is called without an interpreter - but it may depend on the shell in use when called. -@REM If you find yourself really wanting/needing to add a shebang line - do so on the basis that the script will exist on unix-like systems only. -@SETLOCAL EnableExtensions EnableDelayedExpansion -@SET "validshells= ^(10^) 'pwsh' ^(11^) 'sh' (^12^) 'bash' (^13^) 'tclsh'" -@SET "shells[10]=pwsh" -@SET "shells[11]=sh" -@set "shells[12]=bash" -@SET "shells[13]=tclsh" -: -@SET "nextshell=13" -: -@rem asadmin is for automatic elevation to administrator. Separate window will be created (seems unavoidable with current elevation mechanism) and user will still get security prompt (probably reasonable). -: -@SET "asadmin=0" -: -@REM nextshell set to index for validshells .eg 10 for pwsh -@REM @ECHO nextshell is %nextshell% -@SET "selected=!shells[%nextshell%]!" -@REM @ECHO selected %selected% -@CALL SET "keyRemoved=%%validshells:'!selected!'=%%" -@REM @ECHO keyremoved %keyRemoved% -@REM Note that 'powershell' e.g v5 is just a fallback for when pwsh is not available -@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### -@REM -- cmd/batch file section (ignored on unix but should be left in place) -@REM -- This section intended mainly to launch the next shell (and to escalate privileges if necessary) -@REM -- Avoid customising this if you are not familiar with batch scripting. cmd/batch script can be useful, but is probably the least expressive language and most error prone. -@REM -- For example - as this file needs to use unix-style lf line-endings - the label scanner is susceptible to the 512Byte boundary issue: https://www.dostips.com/forum/viewtopic.php?t=8988#p58888 -@REM -- This label issue can be triggered/abused in files with crlf line endings too - but it is less likely to happen accidentaly. -@REm -- See also: https://stackoverflow.com/questions/4094699/how-does-the-windows-command-interpreter-cmd-exe-parse-scripts/4095133#4095133 -@REM ############################################################################################################################ -@REM -- Due to this issue -seemingly trivial edits of the batch file section can break the script! (for Windows anyway) -@REM -- Even something as simple as adding or removing an @REM -@REM -- From within punkshell - use: -@REM -- pmix scriptwrap.checkfile -@REM -- to check your templates or final wrapped scripts for byte boundary issues -@REM -- It will report any labels that are on boundaries -@REM -- This is why the nextshell value above is a 2 digit key instead of a string - so that editing the value doesn't change the byte offsets. -@REM -- Editing your sh,bash,tcl,pwsh payloads is much less likely to cause an issue. There is the possibility of the final batch :exit_multishell label spanning a boundary - so testing using pmix scriptwrap.checkfile is still recommended. -@REM -- Alternatively, as you should do anyway - test the final script on windows -@REM -- Aside from adding comments/whitespace to tweak the location of labels - you can try duplicating the label (e.g just add the label on a line above) but this is not guaranteed to work in all situations. -@REM -- '@REM' is a safer comment mechanism than a leading colon - which is used sparingly here. -@REM -- A colon anywhere in the script that happens to land on a 512 Byte boundary (from file start or from a callsite) could be misinterpreted as a label -@REM -- It is unknown what versions of cmd interpreters behave this way - and pmix scriptwrap.checkfile doesn't check all such boundaries. -@REm -- For this reason, batch labels should be chosen to be relatively unlikely to collide with other strings in the file, and simple names such as :exit or :end should probably be avoided -@REM ############################################################################################################################ -@REM -- custom windows payloads should be in powershell,tclsh (or sh/bash if available) code sections -@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### -@SET "winpath=%~dp0" -@SET "fname=%~nx0" -@REM @ECHO fname %fname% -@REM @ECHO winpath %winpath% -@REM @ECHO commandlineascalled %0 -@REM @ECHO commandlineresolved %~f0 -@CALL :getNormalizedScriptTail nftail -@REM @ECHO normalizedscripttail %nftail% -@CALL :getFileTail %0 clinetail -@REM @ECHO clinetail %clinetail% -@CALL :stringToUpper %~nx0 capscripttail -@REM @ECHO capscriptname: %capscripttail% - -@IF "%nftail%"=="%capscripttail%" ( - @ECHO forcing asadmin=1 due to file name on filesystem being uppercase - @SET "asadmin=1" -) else ( - @CALL :stringToUpper %clinetail% capcmdlinetail - @REM @ECHO capcmdlinetail !capcmdlinetail! - IF "%clinetail%"=="!capcmdlinetail!" ( - @ECHO forcing asadmin=1 due to cmdline scriptname in uppercase - @set "asadmin=1" - ) -) -@SET "vbsGetPrivileges=%temp%\punk_bat_elevate_%fname%.vbs" -@SET arglist=%* -@IF "%1"=="PUNK-ELEVATED" ( - GOTO :gotPrivileges -) -@IF !asadmin!==1 ( - net file 1>NUL 2>NUL - @IF '!errorlevel!'=='0' ( GOTO :gotPrivileges ) else ( GOTO :getPrivileges ) -) -@GOTO skip_privileges -:getPrivileges -@IF '%1'=='PUNK-ELEVATED' (echo PUNK-ELEVATED & shift /1 & goto :gotPrivileges ) -@ECHO Set UAC = CreateObject^("Shell.Application"^) > "%vbsGetPrivileges%" -@ECHO args = "PUNK-ELEVATED " >> "%vbsGetPrivileges%" -@ECHO For Each strArg in WScript.Arguments >> "%vbsGetPrivileges%" -@ECHO args = args ^& strArg ^& " " >> "%vbsGetPrivileges%" -@ECHO Next >> "%vbsGetPrivileges%" -@ECHO UAC.ShellExecute "%~dp0%~n0.cmd", args, "", "runas", 1 >> "%vbsGetPrivileges%" -@ECHO Launching script in new windows due to administrator elevation -@"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" %* -@EXIT /B - -:gotPrivileges -@REM setlocal & pushd . -@PUSHD . -@cd /d %~dp0 -@IF "%1"=="PUNK-ELEVATED" ( - @DEL "%vbsGetPrivileges%" 1>nul 2>nul - @SET arglist=%arglist:~14% -) - -:skip_privileges -@SET need_ps1=0 -@REM we want the ps1 to exist even if the nextshell isn't powershell -@if not exist "%~dp0%~n0.ps1" ( - @SET need_ps1=1 -) ELSE ( - fc "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >nul || goto different - @REM @ECHO "files same" - @SET need_ps1=0 -) -@GOTO :pscontinue -:different -@REM @ECHO "files differ" -@SET need_ps1=1 -:pscontinue -@IF !need_ps1!==1 ( - COPY "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >NUL -) -@REM avoid using CALL to launch pwsh,tclsh etc - it will intercept some args such as /? -@IF "!shells[%nextshell%]!"=="pwsh" ( - REM pws vs powershell hasn't been tested because we didn't need to copy cmd to ps1 this time - REM test availability of preferred option of powershell7+ pwsh - pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; write-host "statusmessage: pwsh-found" >NUL - SET pwshtest_exitcode=!errorlevel! - REM ECHO pwshtest_exitcode !pwshtest_exitcode! - REM fallback to powershell if pwsh failed - IF !pwshtest_exitcode!==0 ( - pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%~dp0%~n0.ps1" %arglist% & SET task_exitcode=!errorlevel! - ) ELSE ( - REM CALL powershell -nop -nol -c write-host powershell-found - REM powershell -nop -nol -file "%~dp0%~n0.ps1" %* - powershell -nop -nol -c set-executionpolicy -Scope Process Unrestricted; %~dp0%~n0.ps1" %arglist% - SET task_exitcode=!errorlevel! - ) -) ELSE ( - IF "!shells[%nextshell%]!"=="bash" ( - CALL :getWslPath %winpath% wslpath - REM ECHO wslfullpath "!wslpath!%fname%" - !shells[%nextshell%]! "!wslpath!%fname%" %arglist% & SET task_exitcode=!errorlevel! - ) ELSE ( - REM probably tclsh or sh - IF NOT "x%keyRemoved%"=="x%validshells%" ( - REM sh on windows uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl - REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx - !shells[%nextshell%]! "%~dp0%fname%" %arglist% & SET task_exitcode=!errorlevel! - ) ELSE ( - ECHO %fname% has invalid nextshell value ^(%nextshell%^) !shells[%nextshell%]! valid options are %validshells% - SET task_exitcode=66 - GOTO :exit_multishell - ) - ) -) -@REM batch file library functions -@GOTO :endlib - -:getWslPath -@SETLOCAL - @SET "_path=%~p1" - @SET "name=%~nx1" - @SET "drive=%~d1" - @SET "rtrn=%~2" - @SET "result=/mnt/%drive:~0,1%%_path:\=/%%name%" -@ENDLOCAL & ( - @if "%~2" neq "" ( - SET "%rtrn%=%result%" - ) ELSE ( - ECHO %result% - ) -) -@EXIT /B - -:getFileTail -@REM return tail of file without any normalization e.g c:/punkshell/bin/Punk.cmd returns Punk.cmd even if file is punk.cmd -@REM we can't use things such as %~nx1 as it can change capitalisation -@REM This function is designed explicitly to preserve capitalisation -@REM accepts full paths with either / or \ as delimiters - or -@SETLOCAL - @SET "rtrn=%~2" - @SET "arg=%~1" - @REM @SET "result=%_arg:*/=%" - @REM @SET "result=%~1" - @SET LF=^ - - - : The above 2 empty lines are important. Don't remove - @CALL :stringContains "!arg!" "\" hasBackSlash - @IF "!hasBackslash!"=="true" ( - @for %%A in ("!LF!") do @( - @FOR /F %%B in ("!arg:\=%%~A!") do @set "result=%%B" - ) - ) ELSE ( - @CALL :stringContains "!arg!" "/" hasForwardSlash - @IF "!hasForwardSlash!"=="true" ( - @FOR %%A in ("!LF!") do @( - @FOR /F %%B in ("!arg:/=%%~A!") do @set "result=%%B" - ) - ) ELSE ( - @set "result=%arg%" - ) - ) -@ENDLOCAL & ( - @if "%~2" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO %result% - ) -) -@EXIT /B -@REM boundary padding -:getNormalizedScriptTail -@SETLOCAL - @SET "result=%~nx0" - @SET "rtrn=%~1" -@ENDLOCAL & ( - @IF "%~1" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO %result% - ) -) -@EXIT /B - -:getNormalizedFileTailFromPath -@REM warn via echo, and do not set return variable if path not found -@REM note that %~nx1 does not preserve case of provided path - hence the name 'normalized' -@REM boundary padding -@REM boundary padding -@SETLOCAL - @CALL :stringContains %~1 "\" hasBackSlash - @CALL :stringContains %~1 "/" hasForwardSlash - @IF "%hasBackslash%-%hasForwardslash%"=="false-false" ( - @SET "P=%cd%%~1" - @CALL :getNormalizedFileTailFromPath "!P!" ftail2 - @SET "result=!ftail2!" - ) else ( - @IF EXIST "%~1" ( - @SET "result=%~nx1" - ) else ( - @ECHO error getNormalizedFileTailFromPath file not found: %~1 - @EXIT /B 1 - ) - ) - @SET "rtrn=%~2" -@ENDLOCAL & ( - @IF "%~2" neq "" ( - SET "%rtrn%=%result%" - ) ELSE ( - @ECHO getNormalizedFileTailFromPath %1 result: %result% - ) -) -@EXIT /B - -:stringContains -@REM usage: @CALL:stringContains string needle returnvarname -@SETLOCAL - @SET "rtrn=%~3" - @SET "string=%~1" - @SET "needle=%~2" - @IF "!string:%needle%=!"=="!string!" @( - @SET "result=false" - ) ELSE ( - @SET "result=true" - ) -@ENDLOCAL & ( - @IF "%~3" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO stringContains %string% %needle% result: %result% - ) -) -@EXIT /B - -:stringToUpper -@SETLOCAL - @SET "rtrn=%~2" - @SET "string=%~1" - @SET "capstring=%~1" - @FOR %%A in (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z) DO @( - @SET "capstring=!capstring:%%A=%%A!" - ) - @SET "result=!capstring!" -@ENDLOCAL & ( - @IF "%~2" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO stringToUpper %string% result: %result% - ) -) -@EXIT /B - -:isNumeric -@SETLOCAL - @SET "notnumeric="&FOR /F "delims=0123456789" %%i in ("%1") do set "notnumeric=%%i" - @IF defined notnumeric ( - @SET "result=false" - ) else ( - @SET "result=true" - ) - @SET "rtrn=%~2" -@ENDLOCAL & ( - @IF "%~2" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO %result% - ) -) -@EXIT /B - -:endlib -: \ -@REM @SET taskexit_code=!errorlevel! & goto :exit_multishell -@GOTO :exit_multishell -# } -# -*- tcl -*- -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- tcl script section -# -- This is a punk multishell file -# -- Primary payload target is Tcl, with sh,bash,powershell as helpers -# -- but it may equally be used with any of these being the primary script. -# -- It is tuned to run when called as a batch file, a tcl script a sh/bash script or a pwsh/powershell script -# -- i.e it is a polyglot file. -# -- The specific layout including some lines that appear just as comments is quite sensitive to change. -# -- It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. -# -- e.g ./filename.polypunk.cmd in sh or bash -# -- e.g tclsh filename.cmd -# -- -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -rename set ""; rename s set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore -Hide :exit_multishell;Hide {<#};Hide '@ -namespace eval ::punk::multishell { - set last_script_root [file dirname [file normalize ${argv0}/__]] - set last_script [file dirname [file normalize [info script]/__]] - if {[info exists argv0] && - $last_script eq $last_script_root - } { - set ::punk::multishell::is_main($last_script) 1 ;#run as executable/script - likely desirable to launch application and return an exitcode - } else { - set ::punk::multishell::is_main($last_script) 0 ;#sourced - likely to be being used as a library - no launch, no exit. Can use return. - } - if {"::punk::multishell::is_main" ni [info commands ::punk::multishell::is_main]} { - proc ::punk::multishell::is_main {{script_name {}}} { - if {$script_name eq ""} { - set script_name [file dirname [file normalize [info script]/--]] - } - if {![info exists ::punk::multishell::is_main($script_name)]} { - #e.g a .dll or something else unanticipated - puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting" - puts stderr "Info: script_root: [file dirname [file normalize ${argv0}/__]]" - return 0 - } - return [set ::punk::multishell::is_main($script_name)] - } - } -} -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload -#puts "script : [info script]" -#puts "argcount : $::argc" -#puts "argvalues: $::argv" -#puts "argv0 : $::argv0" -# -- --- --- --- --- --- --- --- --- --- --- --- - - -# -# - - - -# -- --- --- --- --- --- --- --- --- --- --- --- -# -- Best practice is to always return or exit above, or just by leaving the below defaults in place. -# -- If the multishell script is modified to have Tcl below the Tcl Payload section, -# -- then Tcl bracket balancing needs to be carefully managed in the shell and powershell sections below. -# -- Only the # in front of the two relevant if statements below needs to be removed to enable Tcl below -# -- but the sh/bash 'then' and 'fi' would also need to be uncommented. -# -- This facility left in place for experiments on whether configuration payloads etc can be appended -# -- to tail of file - possibly binary with ctrl-z char - but utility is dependent on which other interpreters/shells -# -- can be made to ignore/cope with such data. -if {[::punk::multishell::is_main]} { - exit 0 -} else { - return -} -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload -# end hide from unix shells \ -HEREDOC1B_HIDE_FROM_BASH_AND_SH -# sh/bash \ -shift && set -- "${@:1:$#-1}" -#------------------------------------------------------ -# -- This if block only needed if Tcl didn't exit or return above. -if false==false # else { - then - : # -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- sh/bash script section -# -- leave as is if all that is required is launching the Tcl payload" -# -- -# -- Note that sh/bash script isn't called when running a .bat/.cmd from cmd.exe on windows by default -# -- adjust @call line above ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate -# -- if sh/bash scripting needs to run on windows too. -# -- -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload -#printf "start of bash or sh code" - -# -# - -# -- --- --- --- --- --- --- --- -# -exitcode=0 ;#default assumption -#-- sh/bash launches Tcl here instead of shebang line at top -#-- use exec to use exitcode (if any) directly from the tcl script -#exec /usr/bin/env tclsh "$0" "$@" -#-- alternative - can run sh/bash script after the tcl call. -/usr/bin/env tclsh "$0" "$@" -exitcode=$? -#echo "tcl exitcode: ${exitcode}" -#-- override exitcode example -#exit 66 -# -# -- --- --- --- --- --- --- --- - -# -# - - -#printf "sh/bash done \n" -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end sh Payload -#------------------------------------------------------ -fi -exit ${exitcode} -# end hide sh/bash block from Tcl -# This comment with closing brace should stay in place whether if commented or not } -#------------------------------------------------------ -# begin hide powershell-block from Tcl - only needed if Tcl didn't exit or return above -if 0 { -: end heredoc1 - end hide from powershell \ -'@ -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- powershell/pwsh section -# -- Do not edit if current file is the .ps1 -# -- Edit the corresponding .cmd and it will autocopy -# -- unbalanced braces { } here *even in comments* will cause problems if there was no Tcl exit or return above -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -function GetScriptName { $myInvocation.ScriptName } -$scriptname = getScriptName -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload -#"Timestamp : {0,10:yyyy-MM-dd HH:mm:ss}" -f $(Get-Date) | write-host -#"Script Name : {0}" -f $scriptname | write-host -#"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host -#"powershell args : {0}" -f ($args -join ", ") | write-host -# -- --- --- --- - -# -# - - -# -- --- --- --- --- --- --- --- -# -tclsh $scriptname $args -# -# -- --- --- --- --- --- --- --- - - -# -# - -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload -#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host -Exit $LASTEXITCODE -# heredoc2 for powershell to ignore block below -$1 = @' -' -: comment end hide powershell-block from Tcl \ -# This comment with closing brace should stay in place whether 'if' commented or not } -: multishell doubled-up cmd exit label - return exitcode -:exit_multishell -:exit_multishell -: \ -@REM @ECHO exitcode: !task_exitcode! -: \ -@IF "%1"=="PUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit) -: \ -@EXIT /B !task_exitcode! -# cmd has exited -: comment end heredoc2 \ -'@ -<# -# id:tailblock0 -# -- powershell multiline comment -#> -<# -# id:tailblock1 -# - -# -# -- unreachable by tcl directly if ctrl-z character is in the section above. (but file can be read and split on \x1A) -# -- Potential for zip and/or base64 contents, but we can't stop pwsh parser from slurping in the data -# -- so for example a plain text tar archive could cause problems depending on the content. -# -- final line in file must be the powershell multiline comment terminator or other data it can handle. -# -- e.g plain # comment lines will work too -# -- (for example a powershell digital signature is a # commented block of data at the end of the file) -#> - - diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell4.cmd b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell4.cmd deleted file mode 100644 index a9688b6a..00000000 --- a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell4.cmd +++ /dev/null @@ -1,680 +0,0 @@ -: "punk MULTISHELL - shebangless polyglot for Tcl Perl sh bash cmd pwsh powershell" + "[rename set s;proc Hide x {proc $x args {}};Hide :]" + "\$(function : {<#pwsh#>})" + "perlhide" + qw^ -set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' -: heredoc1 - hide from powershell using @ and squote above. close sqote for unix shells + ' \ -: .bat/.cmd launch section, leading colon hides from cmd, trailing slash hides next line from tcl + \ -: "[Hide @GOTO; Hide =begin; Hide @REM] #not necessary but can help avoid errs in testing" + -: << 'HEREDOC1B_HIDE_FROM_BASH_AND_SH' -: STRONG SUGGESTION: DO NOT MODIFY FIRST LINE OF THIS SCRIPT - except for first double quoted section. -: shebang line is not required on unix or windows and will reduce functionality and/or portability. -: Even comment lines can be part of the functionality of this script (both on unix and windows) - modify with care. -@GOTO :skip_perl_pod_start ^; -=begin excludeperl -: skip_perl_pod_start -: Continuation char at end of this line and rem with curly-braces used to exlude Tcl from the whole cmd block \ -: { -@REM ############################################################################################################################ -@REM THIS IS A POLYGLOT SCRIPT - supporting payloads in Tcl, bash, sh and/or powershelll (powershell.exe or pwsh.exe) -@REM It should remain portable between unix-like OSes & windows if the proper structure is maintained. -@REM ############################################################################################################################ -@REM On windows, change the value of nextshell to one of the listed 2 digit values if desired, and add code within payload sections for tcl,sh,bash,powershell as appropriate. -@REM This wrapper can be edited manually (carefully!) - or sh,bash,tcl,powershell scripts can be wrapped using the Tcl-based punkshell system -@REM e.g from within a running punkshell: deck scriptwrap.multishell -outputfolder -@REM On unix-like systems, call with sh, bash or tclsh. (powershell untested on unix - and requires wscript if security elevation is used) -@REM Due to lack of shebang (#! line) Unix-like systems will probably (hopefully) default to sh if the script is called without an interpreter - but it may depend on the shell in use when called. -@REM If you find yourself really wanting/needing to add a shebang line - do so on the basis that the script will exist on unix-like systems only. -@SETLOCAL EnableExtensions EnableDelayedExpansion -@SET "validshells= ^(10^) 'pwsh' ^(11^) 'sh' (^12^) 'bash' (^13^) 'tclsh' (^14^) 'perl'" -@SET "shells[10]=pwsh" -@SET "shells[11]=sh" -@set "shells[12]=bash" -@SET "shells[13]=tclsh" -@SET "shells[14]=perl" -: -@SET "nextshell=13" -: -@rem asadmin is for automatic elevation to administrator. Separate window will be created (seems unavoidable with current elevation mechanism) and user will still get security prompt (probably reasonable). -: -@SET "asadmin=0" -: -@REM nextshell set to index for validshells .eg 10 for pwsh -@REM @ECHO nextshell is %nextshell% -@SET "selected=!shells[%nextshell%]!" -@REM @ECHO selected %selected% -@CALL SET "keyRemoved=%%validshells:'!selected!'=%%" -@REM @ECHO keyremoved %keyRemoved% -@REM Note that 'powershell' e.g v5 is just a fallback for when pwsh is not available -@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### -@REM -- cmd/batch file section (ignored on unix but should be left in place) -@REM -- This section intended mainly to launch the next shell (and to escalate privileges if necessary) -@REM -- Avoid customising this if you are not familiar with batch scripting. cmd/batch script can be useful, but is probably the least expressive language and most error prone. -@REM -- For example - as this file needs to use unix-style lf line-endings - the label scanner is susceptible to the 512Byte boundary issue: https://www.dostips.com/forum/viewtopic.php?t=8988#p58888 -@REM -- This label issue can be triggered/abused in files with crlf line endings too - but it is less likely to happen accidentaly. -@REm -- See also: https://stackoverflow.com/questions/4094699/how-does-the-windows-command-interpreter-cmd-exe-parse-scripts/4095133#4095133 -@REM ############################################################################################################################ -@REM -- Due to this issue -seemingly trivial edits of the batch file section can break the script! (for Windows anyway) -@REM -- Even something as simple as adding or removing an @REM -@REM -- From within punkshell - use: -@REM -- deck scriptwrap.checkfile -@REM -- to check your templates or final wrapped scripts for byte boundary issues -@REM -- It will report any labels that are on boundaries -@REM -- This is why the nextshell value above is a 2 digit key instead of a string - so that editing the value doesn't change the byte offsets. -@REM -- Editing your sh,bash,tcl,pwsh payloads is much less likely to cause an issue. There is the possibility of the final batch :exit_multishell label spanning a boundary - so testing using deck scriptwrap.checkfile is still recommended. -@REM -- Alternatively, as you should do anyway - test the final script on windows -@REM -- Aside from adding comments/whitespace to tweak the location of labels - you can try duplicating the label (e.g just add the label on a line above) but this is not guaranteed to work in all situations. -@REM -- '@REM' is a safer comment mechanism than a leading colon - which is used sparingly here. -@REM -- A colon anywhere in the script that happens to land on a 512 Byte boundary (from file start or from a callsite) could be misinterpreted as a label -@REM -- It is unknown what versions of cmd interpreters behave this way - and deck scriptwrap.checkfile doesn't check all such boundaries. -@REm -- For this reason, batch labels should be chosen to be relatively unlikely to collide with other strings in the file, and simple names such as :exit or :end should probably be avoided -@REM ############################################################################################################################ -@REM -- custom windows payloads should be in powershell,tclsh (or sh/bash if available) code sections -@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ### -@SET "winpath=%~dp0" -@SET "fname=%~nx0" -@REM @ECHO fname %fname% -@REM @ECHO winpath %winpath% -@REM @ECHO commandlineascalled %0 -@REM @ECHO commandlineresolved %~f0 -@CALL :getNormalizedScriptTail nftail -@REM @ECHO normalizedscripttail %nftail% -@CALL :getFileTail %0 clinetail -@REM @ECHO clinetail %clinetail% -@CALL :stringToUpper %~nx0 capscripttail -@REM @ECHO capscriptname: %capscripttail% - -@IF "%nftail%"=="%capscripttail%" ( - @ECHO forcing asadmin=1 due to file name on filesystem being uppercase - @SET "asadmin=1" -) else ( - @CALL :stringToUpper %clinetail% capcmdlinetail - @REM @ECHO capcmdlinetail !capcmdlinetail! - IF "%clinetail%"=="!capcmdlinetail!" ( - @ECHO forcing asadmin=1 due to cmdline scriptname in uppercase - @set "asadmin=1" - ) -) -@SET "vbsGetPrivileges=%temp%\punk_bat_elevate_%fname%.vbs" -@SET arglist=%* -@SET "qstrippedargs=args%arglist%" -@SET "qstrippedargs=%qstrippedargs:"=%" -@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" ( - GOTO :gotPrivileges -) -@IF !asadmin!==1 ( - net file 1>NUL 2>NUL - @IF '!errorlevel!'=='0' ( GOTO :gotPrivileges ) else ( GOTO :getPrivileges ) -) -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@REM -@GOTO skip_privileges -:getPrivileges -@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (echo PUNK-ELEVATED & shift /1 & goto :gotPrivileges ) -@ECHO Set UAC = CreateObject^("Shell.Application"^) > "%vbsGetPrivileges%" -@ECHO args = "PUNK-ELEVATED " >> "%vbsGetPrivileges%" -@ECHO For Each strArg in WScript.Arguments >> "%vbsGetPrivileges%" -@ECHO args = args ^& strArg ^& " " >> "%vbsGetPrivileges%" -@ECHO Next >> "%vbsGetPrivileges%" -@ECHO UAC.ShellExecute "%~dp0%~n0%~x0", args, "", "runas", 1 >> "%vbsGetPrivileges%" -@ECHO Launching script in new windows due to administrator elevation -@"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" %* -@EXIT /B - -:gotPrivileges -@REM setlocal & pushd . -@PUSHD . -@cd /d %~dp0 -@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" ( - @DEL "%vbsGetPrivileges%" 1>nul 2>nul - @SET arglist=%arglist:~14% -) - -:skip_privileges -@SET need_ps1=0 -@REM we want the ps1 to exist even if the nextshell isn't powershell -@if not exist "%~dp0%~n0.ps1" ( - @SET need_ps1=1 -) ELSE ( - fc "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >nul || goto different - @REM @ECHO "files same" - @SET need_ps1=0 -) -@GOTO :pscontinue -:different -@REM @ECHO "files differ" -@SET need_ps1=1 -:pscontinue -@IF !need_ps1!==1 ( - COPY "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >NUL -) -@REM avoid using CALL to launch pwsh,tclsh etc - it will intercept some args such as /? -@IF "!shells[%nextshell%]!"=="pwsh" ( - REM pws vs powershell hasn't been tested because we didn't need to copy cmd to ps1 this time - REM test availability of preferred option of powershell7+ pwsh - pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; write-host "statusmessage: pwsh-found" >NUL - SET pwshtest_exitcode=!errorlevel! - REM ECHO pwshtest_exitcode !pwshtest_exitcode! - REM fallback to powershell if pwsh failed - IF !pwshtest_exitcode!==0 ( - pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%~dp0%~n0.ps1" %arglist% - SET task_exitcode=!errorlevel! - ) ELSE ( - REM CALL powershell -nop -nol -c write-host powershell-found - REM powershell -nop -nol -file "%~dp0%~n0.ps1" %* - powershell -nop -nol -c set-executionpolicy -Scope Process Unrestricted; %~dp0%~n0.ps1" %arglist% - SET task_exitcode=!errorlevel! - ) -) ELSE ( - IF "!shells[%nextshell%]!"=="bash" ( - CALL :getWslPath %winpath% wslpath - REM ECHO wslfullpath "!wslpath!%fname%" - !shells[%nextshell%]! "!wslpath!%fname%" %arglist% - SET task_exitcode=!errorlevel! - ) ELSE ( - REM probably tclsh or sh - IF NOT "x%keyRemoved%"=="x%validshells%" ( - REM sh on windows uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl - REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx - !shells[%nextshell%]! "%~dp0%fname%" %arglist% - SET task_exitcode=!errorlevel! - ) ELSE ( - ECHO %fname% has invalid nextshell value ^(%nextshell%^) !shells[%nextshell%]! valid options are %validshells% - SET task_exitcode=66 - @REM boundary padding - @REM boundary padding - GOTO :exit_multishell - ) - ) -) -@REM batch file library functions -@REM boundary padding -@GOTO :endlib - -:getWslPath -@SETLOCAL - @SET "_path=%~p1" - @SET "name=%~nx1" - @SET "drive=%~d1" - @SET "rtrn=%~2" - @SET "result=/mnt/%drive:~0,1%%_path:\=/%%name%" -@ENDLOCAL & ( - @if "%~2" neq "" ( - SET "%rtrn%=%result%" - ) ELSE ( - ECHO %result% - ) -) -@EXIT /B - -:getFileTail -@REM return tail of file without any normalization e.g c:/punkshell/bin/Punk.cmd returns Punk.cmd even if file is punk.cmd -@REM we can't use things such as %~nx1 as it can change capitalisation -@REM This function is designed explicitly to preserve capitalisation -@REM accepts full paths with either / or \ as delimiters - or -@SETLOCAL - @SET "rtrn=%~2" - @SET "arg=%~1" - @REM @SET "result=%_arg:*/=%" - @REM @SET "result=%~1" - @SET LF=^ - - - : The above 2 empty lines are important. Don't remove - @CALL :stringContains "!arg!" "\" hasBackSlash - @IF "!hasBackslash!"=="true" ( - @for %%A in ("!LF!") do @( - @FOR /F %%B in ("!arg:\=%%~A!") do @set "result=%%B" - ) - ) ELSE ( - @CALL :stringContains "!arg!" "/" hasForwardSlash - @IF "!hasForwardSlash!"=="true" ( - @FOR %%A in ("!LF!") do @( - @FOR /F %%B in ("!arg:/=%%~A!") do @set "result=%%B" - ) - ) ELSE ( - @set "result=%arg%" - ) - ) -@ENDLOCAL & ( - @if "%~2" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO %result% - ) -) -@EXIT /B -@REM boundary padding -@REM boundary padding -:getNormalizedScriptTail -@SETLOCAL - @SET "result=%~nx0" - @SET "rtrn=%~1" -@ENDLOCAL & ( - @IF "%~1" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO %result% - ) -) -@EXIT /B - -:getNormalizedFileTailFromPath -@REM warn via echo, and do not set return variable if path not found -@REM note that %~nx1 does not preserve case of provided path - hence the name 'normalized' -@REM boundary padding -@REM boundary padding -@REM boundary padding -@REM boundary padding -@SETLOCAL - @CALL :stringContains %~1 "\" hasBackSlash - @CALL :stringContains %~1 "/" hasForwardSlash - @IF "%hasBackslash%-%hasForwardslash%"=="false-false" ( - @SET "P=%cd%%~1" - @CALL :getNormalizedFileTailFromPath "!P!" ftail2 - @SET "result=!ftail2!" - ) else ( - @IF EXIST "%~1" ( - @SET "result=%~nx1" - ) else ( - @ECHO error getNormalizedFileTailFromPath file not found: %~1 - @EXIT /B 1 - ) - ) - @SET "rtrn=%~2" -@ENDLOCAL & ( - @IF "%~2" neq "" ( - SET "%rtrn%=%result%" - ) ELSE ( - @ECHO getNormalizedFileTailFromPath %1 result: %result% - ) -) -@EXIT /B - -:stringContains -@REM usage: @CALL:stringContains string needle returnvarname -@SETLOCAL - @SET "rtrn=%~3" - @SET "string=%~1" - @SET "needle=%~2" - @IF "!string:%needle%=!"=="!string!" @( - @SET "result=false" - ) ELSE ( - @SET "result=true" - ) -@ENDLOCAL & ( - @IF "%~3" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO stringContains %string% %needle% result: %result% - ) -) -@EXIT /B - -:stringToUpper -@SETLOCAL - @SET "rtrn=%~2" - @SET "string=%~1" - @SET "capstring=%~1" - @FOR %%A in (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z) DO @( - @SET "capstring=!capstring:%%A=%%A!" - ) - @SET "result=!capstring!" -@ENDLOCAL & ( - @IF "%~2" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO stringToUpper %string% result: %result% - ) -) -@EXIT /B - -:isNumeric -@SETLOCAL - @SET "notnumeric="&FOR /F "delims=0123456789" %%i in ("%1") do set "notnumeric=%%i" - @IF defined notnumeric ( - @SET "result=false" - ) else ( - @SET "result=true" - ) - @SET "rtrn=%~2" -@ENDLOCAL & ( - @IF "%~2" neq "" ( - @SET "%rtrn%=%result%" - ) ELSE ( - @ECHO %result% - ) -) -@EXIT /B - -:endlib -: \ -@REM @SET taskexit_code=!errorlevel! & goto :exit_multishell -@GOTO :exit_multishell -# } -# -*- tcl -*- -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- tcl script section -# -- This is a punk multishell file -# -- Primary payload target is Tcl, with sh,bash,powershell as helpers -# -- but it may equally be used with any of these being the primary script. -# -- It is tuned to run when called as a batch file, a tcl script a sh/bash script or a pwsh/powershell script -# -- i.e it is a polyglot file. -# -- The specific layout including some lines that appear just as comments is quite sensitive to change. -# -- It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. -# -- e.g ./filename.polypunk.cmd in sh or bash -# -- e.g tclsh filename.cmd -# -- -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -rename set ""; rename s set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore -Hide :exit_multishell;Hide {<#};Hide '@ -namespace eval ::punk::multishell { - set last_script_root [file dirname [file normalize ${argv0}/__]] - set last_script [file dirname [file normalize [info script]/__]] - if {[info exists argv0] && - $last_script eq $last_script_root - } { - set ::punk::multishell::is_main($last_script) 1 ;#run as executable/script - likely desirable to launch application and return an exitcode - } else { - set ::punk::multishell::is_main($last_script) 0 ;#sourced - likely to be being used as a library - no launch, no exit. Can use return. - } - if {"::punk::multishell::is_main" ni [info commands ::punk::multishell::is_main]} { - proc ::punk::multishell::is_main {{script_name {}}} { - if {$script_name eq ""} { - set script_name [file dirname [file normalize [info script]/--]] - } - if {![info exists ::punk::multishell::is_main($script_name)]} { - #e.g a .dll or something else unanticipated - puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting" - puts stderr "Info: script_root: [file dirname [file normalize ${argv0}/__]]" - return 0 - } - return [set ::punk::multishell::is_main($script_name)] - } - } -} -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload -#puts "script : [info script]" -#puts "argcount : $::argc" -#puts "argvalues: $::argv" -#puts "argv0 : $::argv0" -# -- --- --- --- --- --- --- --- --- --- --- --- - - -# -# - -# -# - - -# -# - - -# -- --- --- --- --- --- --- --- --- --- --- --- -# -- Best practice is to always return or exit above, or just by leaving the below defaults in place. -# -- If the multishell script is modified to have Tcl below the Tcl Payload section, -# -- then Tcl bracket balancing needs to be carefully managed in the shell and powershell sections below. -# -- Only the # in front of the two relevant if statements below needs to be removed to enable Tcl below -# -- but the sh/bash 'then' and 'fi' would also need to be uncommented. -# -- This facility left in place for experiments on whether configuration payloads etc can be appended -# -- to tail of file - possibly binary with ctrl-z char - but utility is dependent on which other interpreters/shells -# -- can be made to ignore/cope with such data. -if {[::punk::multishell::is_main]} { - exit 0 -} else { - return -} -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload -# end hide from unix shells \ -HEREDOC1B_HIDE_FROM_BASH_AND_SH -# sh/bash \ -shift && set -- "${@:1:$#-1}" -#------------------------------------------------------ -# -- This if block only needed if Tcl didn't exit or return above. -if false==false # else { - then - : # -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- sh/bash script section -# -- leave as is if all that is required is launching the Tcl payload" -# -- -# -- Note that sh/bash script isn't called when running a .bat/.cmd from cmd.exe on windows by default -# -- adjust the %nextshell% value above -# -- if sh/bash scripting needs to run on windows too. -# -- -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload -exitcode=0 -#printf "start of bash or sh code" - -# -# - -# -- --- --- --- --- --- --- --- -# -#-- sh/bash launches Tcl here instead of shebang line at top -#-- use exec to use exitcode (if any) directly from the tcl script -#exec /usr/bin/env tclsh "$0" "$@" -#-- alternative - can run sh/bash script after the tcl call. -/usr/bin/env tclsh "$0" "$@" -exitcode=$? -#echo "sh/bash reporting tcl exitcode: ${exitcode}" -#-- override exitcode example -#exit 66 -# -# -- --- --- --- --- --- --- --- - -# -# - - -#printf "sh/bash done \n" -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end sh Payload -#------------------------------------------------------ -fi -exit ${exitcode} -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- Perl script section -# -- leave the script below as is, if all that is required is launching the Tcl payload" -# -- -# -- Note that perl script isn't called by default when simply running this script by name -# -- adjust the nextshell value at the top of the script to point to perl -# -- -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -=cut -#!/user/bin/perl -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin perl Payload -my $exit_code = 0; -#use ExtUtils::Installed; -#my $installed = ExtUtils::Installed->new(); -#my @modules = $installed->modules(); -#print "Modules:\n"; -#foreach my $m (@modules) { -# print "$m\n"; -#} -# -- --- --- - - - -my $scriptname = $0; -print "perl $scriptname\n"; -my $i =1; -foreach my $a(@ARGV) { - print "Arg # $i: $a\n"; -} - -# -# - - - -# -- --- --- --- --- --- --- --- -# -$exit_code=system("tclsh", $scriptname, @ARGV); -#print "perl reporting tcl exitcode: $exit_code"; -# -# -- --- --- --- --- --- --- --- - -# -# - - -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end perl Payload -exit $exit_code; -__END__ - -# end hide sh/bash/perl block from Tcl -# This comment with closing brace should stay in place whether if commented or not } -#------------------------------------------------------ -# begin hide powershell-block from Tcl - only needed if Tcl didn't exit or return above -if 0 { -: end heredoc1 - end hide from powershell \ -'@ -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -# -- powershell/pwsh section -# -- Do not edit if current file is the .ps1 -# -- Edit the corresponding .cmd and it will autocopy -# -- unbalanced braces { } here *even in comments* will cause problems if there was no Tcl exit or return above -# -- custom script should generally go below the begin_powershell_payload line -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### -function GetScriptName { $myInvocation.ScriptName } -$scriptname = GetScriptName -function GetDynamicParamDictionary { - [CmdletBinding()] - param( - [Parameter(ValueFromPipeline=$true, Mandatory=$true)] - [string] $CommandName - ) - - begin { - # Get a list of params that should be ignored (they're common to all advanced functions) - $CommonParameterNames = [System.Runtime.Serialization.FormatterServices]::GetUninitializedObject([type] [System.Management.Automation.Internal.CommonParameters]) | - Get-Member -MemberType Properties | - Select-Object -ExpandProperty Name - } - - process { - # Create the dictionary that this scriptblock will return: - $DynParamDictionary = New-Object System.Management.Automation.RuntimeDefinedParameterDictionary - - # Convert to object array and get rid of Common params: - (Get-Command $CommandName | select -exp Parameters).GetEnumerator() | - Where-Object { $CommonParameterNames -notcontains $_.Key } | - ForEach-Object { - $DynamicParameter = New-Object System.Management.Automation.RuntimeDefinedParameter ( - $_.Key, - $_.Value.ParameterType, - $_.Value.Attributes - ) - $DynParamDictionary.Add($_.Key, $DynamicParameter) - } - - # Return the dynamic parameters - return $DynParamDictionary - } -} -# GetDynamicParamDictionary -# - This can make it easier to share a single set of param definitions between functions -# - sample usage -#function ParameterDefinitions { -# param( -# [Parameter(Mandatory)][string] $myargument -# ) -#} -#function psmain { -# [CmdletBinding()] -# param() -# dynamicparam { GetDynamicParamDictionary ParameterDefinitions } -# process { -# #called once with $PSBoundParameters dictionary -# #can be used to validate arguments, or set a simpler variable name for access -# switch ($PSBoundParameters.keys) { -# 'myargumentname' { -# Set-Variable -Name $_ -Value $PSBoundParameters."$_" -# } -# #... -# } -# foreach ($boundparam in $PSBoundParameters.GetEnumerator()) { -# #... -# } -# } -# end { -# #Main function logic -# Write-Host "myargumentname value is: $myargumentname" -# #myotherfunction @PSBoundParameters -# } -#} -#psmain @args -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload -#"Timestamp : {0,10:yyyy-MM-dd HH:mm:ss}" -f $(Get-Date) | write-host -#"Script Name : {0}" -f $scriptname | write-host -#"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host -#"powershell args : {0}" -f ($args -join ", ") | write-host -# -- --- --- --- - -# -# - - -# -- --- --- --- --- --- --- --- -# -tclsh $scriptname $args -#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host -# -# -- --- --- --- --- --- --- --- - - -# -# - -# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload -Exit $LASTEXITCODE -# heredoc2 for powershell to ignore block below -$1 = @' -' -: comment end hide powershell-block from Tcl \ -# This comment with closing brace should stay in place whether 'if' commented or not } -: multishell doubled-up cmd exit label - return exitcode -:exit_multishell -:exit_multishell -: \ -@REM @ECHO exitcode: !task_exitcode! -: \ -@IF "is%qstrippedargs:~4,13%"=="isPUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit) -: \ -@EXIT /B !task_exitcode! -# cmd has exited -: comment end heredoc2 \ -'@ -<# -# id:tailblock0 -# -- powershell multiline comment -#> -<# -no script engine should try to run me -# id:tailblock1 -# - -# -# -- unreachable by tcl directly if ctrl-z character is in the section above. (but file can be read and split on \x1A) -# -- Potential for zip and/or base64 contents, but we can't stop pwsh parser from slurping in the data -# -- so for example a plain text tar archive could cause problems depending on the content. -# -- final line in file must be the powershell multiline comment terminator or other data it can handle. -# -- e.g plain # comment lines will work too -# -- (for example a powershell digital signature is a # commented block of data at the end of the file) -#> - - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argp-0.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argp-0.2.tm deleted file mode 100644 index 1b1f4b78..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argp-0.2.tm +++ /dev/null @@ -1,259 +0,0 @@ - -# Tcl parser for optional arguments in function calls and -# commandline arguments -# -# (c) 2001 Bastien Chevreux - -# Index of exported commands -# - argp::registerArgs -# - argp::setArgDefaults -# - argp::setArgsNeeded -# - argp::parseArgs - -# Internal commands -# - argp::CheckValues - -# See end of file for an example on how to use - -package provide argp 0.2 - -namespace eval argp { - variable Optstore - variable Opttypes { - boolean integer double string - } - - namespace export {[a-z]*} -} - - -proc argp::registerArgs { func arglist } { - variable Opttypes - variable Optstore - - set parentns [string range [uplevel 1 [list namespace current]] 2 end] - if { $parentns != "" } { - append caller $parentns :: $func - } else { - set caller $func - } - set cmangled [string map {:: _} $caller] - - #puts $parentns - #puts $caller - #puts $cmangled - - set Optstore(keys,$cmangled) {} - set Optstore(deflist,$cmangled) {} - set Optstore(argneeded,$cmangled) {} - - foreach arg $arglist { - foreach {opt type default allowed} $arg { - set optindex [lsearch -glob $Opttypes $type*] - if { $optindex < 0} { - return -code error "$caller, unknown type $type while registering arguments.\nAllowed types: [string trim $Opttypes]" - } - set type [lindex $Opttypes $optindex] - - lappend Optstore(keys,$cmangled) $opt - set Optstore(type,$opt,$cmangled) $type - set Optstore(default,$opt,$cmangled) $default - set Optstore(allowed,$opt,$cmangled) $allowed - lappend Optstore(deflist,$cmangled) $opt $default - } - } - - if { [catch {CheckValues $caller $cmangled $Optstore(deflist,$cmangled)} res]} { - return -code error "Error in declaration of optional arguments.\n$res" - } -} - -proc argp::setArgDefaults { func arglist } { - variable Optstore - - set parentns [string range [uplevel 1 [list namespace current]] 2 end] - if { $parentns != "" } { - append caller $parentns :: $func - } else { - set caller $func - } - set cmangled [string map {:: _} $caller] - - if {![info exists Optstore(deflist,$cmangled)]} { - return -code error "Arguments for $caller not registered yet." - } - set Optstore(deflist,$cmangled) {} - foreach {opt default} $arglist { - if {![info exists Optstore(default,$opt,$cmangled)]} { - return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" - } - set Optstore(default,$opt,$cmangled) $default - } - - # set the new defaultlist - foreach opt $Optstore(keys,$cmangled) { - lappend Optstore(deflist,$cmangled) $opt $Optstore(default,$opt,$cmangled) - } -} - -proc argp::setArgsNeeded { func arglist } { - variable Optstore - - set parentns [string range [uplevel 1 [list namespace current]] 2 end] - if { $parentns != "" } { - append caller $parentns :: $func - } else { - set caller $func - } - set cmangled [string map {:: _} $caller] - - #append caller $parentns :: $func - #set cmangled ${parentns}_$func - - if {![info exists Optstore(deflist,$cmangled)]} { - return -code error "Arguments for $caller not registered yet." - } - - set Optstore(argneeded,$cmangled) {} - foreach opt $arglist { - if {![info exists Optstore(default,$opt,$cmangled)]} { - return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" - } - lappend Optstore(argneeded,$cmangled) $opt - } -} - - -proc argp::parseArgs { args } { - variable Optstore - - if {[llength $args] == 0} { - upvar args a opts o - } else { - upvar args a [lindex $args 0] o - } - - if { [ catch { set caller [lindex [info level -1] 0]}]} { - set caller "main program" - set cmangled "" - } else { - set cmangled [string map {:: _} $caller] - } - - if {![info exists Optstore(deflist,$cmangled)]} { - return -code error "Arguments for $caller not registered yet." - } - - # set the defaults - array set o $Optstore(deflist,$cmangled) - - # but unset the needed arguments - foreach key $Optstore(argneeded,$cmangled) { - catch { unset o($key) } - } - - foreach {key val} $a { - if {![info exists Optstore(type,$key,$cmangled)]} { - return -code error "$caller, unknown option $key, must be one of: $Optstore(keys,$cmangled)" - } - switch -exact -- $Optstore(type,$key,$cmangled) { - boolean - - integer { - if { $val == "" } { - return -code error "$caller, $key empty string is not $Optstore(type,$key,$cmangled) value." - } - if { ![string is $Optstore(type,$key,$cmangled) $val]} { - return -code error "$caller, $key $val is not $Optstore(type,$key,$cmangled) value." - } - } - double { - if { $val == "" } { - return -code error "$caller, $key empty string is not double value." - } - if { ![string is double $val]} { - return -code error "$caller, $key $val is not double value." - } - if { [string is integer $val]} { - set val [expr {$val + .0}] - } - } - default { - } - } - set o($key) $val - } - - foreach key $Optstore(argneeded,$cmangled) { - if {![info exists o($key)]} { - return -code error "$caller, needed argument $key was not given." - } - } - - if { [catch { CheckValues $caller $cmangled [array get o]} err]} { - return -code error $err - } - - return -} - - -proc argp::CheckValues { caller cmangled checklist } { - variable Optstore - - #puts "Checking $checklist" - - foreach {key val} $checklist { - if { [llength $Optstore(allowed,$key,$cmangled)] > 0 } { - switch -exact -- $Optstore(type,$key,$cmangled) { - string { - if { [lsearch $Optstore(allowed,$key,$cmangled) $val] < 0} { - return -code error "$caller, $key $val is not in allowed values: $Optstore(allowed,$key,$cmangled)" - } - } - double - - integer { - set found 0 - foreach range $Optstore(allowed,$key,$cmangled) { - if {[llength $range] == 1} { - if { $val == [lindex $range 0] } { - set found 1 - break - } - } elseif {[llength $range] == 2} { - set low [lindex $range 0] - set high [lindex $range 1] - - if { ![string is integer $low] \ - && [string compare "-" $low] != 0} { - return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a lower value range that is not integer and not \u00b4-\u00b4: $range" - } - if { ![string is integer $high] \ - && [string compare "+" $high] != 0} { - return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a upper value range that is not integer and not \u00b4+\u00b4: $range" - } - if {[string compare "-" $low] == 0} { - if { [string compare "+" $high] == 0 \ - || $val <= $high } { - set found 1 - break - } - } - if { $val >= $low } { - if {[string compare "+" $high] == 0 \ - || $val <= $high } { - set found 1 - break - } - } - } else { - return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has an allowed value range containing more than 2 elements: $range" - } - } - if { $found == 0 } { - return -code error "$caller, $key $val is not covered by allowed ranges: $Optstore(allowed,$key,$cmangled)" - } - } - } - } - } -} diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm deleted file mode 100644 index b97d1b4e..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm +++ /dev/null @@ -1,601 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) Julian Noble 2024 -# -# @@ Meta Begin -# Application argparsingtest 0.1.0 -# Meta platform tcl -# Meta license MIT -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_argparsingtest 0 0.1.0] -#[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require argparsingtest] -#[keywords module] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of argparsingtest -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by argparsingtest -#[list_begin itemized] - -package require Tcl 8.6- -package require punk::args -package require struct::set -#*** !doctools -#[item] [package {Tcl 8.6}] -#[item] [package {punk::args}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval argparsingtest::class { - #*** !doctools - #[subsection {Namespace argparsingtest::class}] - #[para] class definitions - if {[info commands [namespace current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval argparsingtest { - namespace export {[a-z]*} ;# Convention: export all lowercase - #variable xyz - - #*** !doctools - #[subsection {Namespace argparsingtest}] - #[para] Core API functions for argparsingtest - #[list_begin definitions] - - proc test1_ni {args} { - set defaults [dict create\ - -return string\ - -frametype \uFFEF\ - -show_edge \uFFEF\ - -show_seps \uFFEF\ - -x ""\ - -y b\ - -z c\ - -1 1\ - -2 2\ - -3 3\ - ] - foreach {k v} $args { - if {$k ni [dict keys $defaults]} { - error "unrecognised option '$k'. Known options [dict keys $defaults]" - } - } - set opts [dict merge $defaults $args] - } - proc test1_switchmerge {args} { - set defaults [dict create\ - -return string\ - -frametype \uFFEF\ - -show_edge \uFFEF\ - -show_seps \uFFEF\ - -x ""\ - -y b\ - -z c\ - -1 1\ - -2 2\ - -3 3\ - ] - foreach {k v} $args { - switch -- $k { - -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 {} - default { - error "unrecognised option '$k'. Known options [dict keys $defaults]" - } - } - } - set opts [dict merge $defaults $args] - } - #if we need to loop to test arg validity anyway - then dict set as we go is slightly faster than a dict merge at the end - proc test1_switch {args} { - set opts [dict create\ - -return string\ - -frametype \uFFEF\ - -show_edge \uFFEF\ - -show_seps \uFFEF\ - -x ""\ - -y b\ - -z c\ - -1 1\ - -2 2\ - -3 3\ - ] - foreach {k v} $args { - switch -- $k { - -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { - dict set opts $k $v - } - default { - error "unrecognised option '$k'. Known options [dict keys $opts]" - } - } - } - return $opts - } - variable switchopts - set switchopts [dict create\ - -return string\ - -frametype \uFFEF\ - -show_edge \uFFEF\ - -show_seps \uFFEF\ - -x ""\ - -y b\ - -z c\ - -1 1\ - -2 2\ - -3 3\ - ] - #slightly slower than just creating the dict within the proc - proc test1_switch_nsvar {args} { - variable switchopts - set opts $switchopts - foreach {k v} $args { - switch -- $k { - -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { - dict set opts $k $v - } - default { - error "unrecognised option '$k'. Known options [dict keys $opts]" - } - } - } - return $opts - } - proc test1_switch2 {args} { - set opts [dict create\ - -return string\ - -frametype \uFFEF\ - -show_edge \uFFEF\ - -show_seps \uFFEF\ - -x ""\ - -y b\ - -z c\ - -1 1\ - -2 2\ - -3 3\ - ] - set switches [lmap v [dict keys $opts] {list $v -}] - set switches [concat {*}$switches] - set switches [lrange $switches 0 end-1] - foreach {k v} $args { - switch -- $k\ - {*}$switches { - dict set opts $k $v - }\ - default { - error "unrecognised option '$k'. Known options [dict keys $opts]" - } - } - return $opts - } - proc test1_prefix {args} { - set opts [dict create\ - -return string\ - -frametype \uFFEF\ - -show_edge \uFFEF\ - -show_seps \uFFEF\ - -x ""\ - -y b\ - -z c\ - -1 1\ - -2 2\ - -3 3\ - ] - foreach {k v} $args { - dict set opts [tcl::prefix::match -message "test1_prefix option $k" {-return -frametype -show_edge -show_seps -x -y -z -1 -2 -3} $k] $v - } - return $opts - } - proc test1_prefix2 {args} { - set opts [dict create\ - -return string\ - -frametype \uFFEF\ - -show_edge \uFFEF\ - -show_seps \uFFEF\ - -x ""\ - -y b\ - -z c\ - -1 1\ - -2 2\ - -3 3\ - ] - if {[llength $args]} { - set knownflags [dict keys $opts] - } - foreach {k v} $args { - dict set opts [tcl::prefix::match -message "test1_prefix2 option $k" $knownflags $k] $v - } - return $opts - } - - #punk::args is slower than argp - but comparable, and argp doesn't support solo flags - proc test1_punkargs {args} { - set argd [punk::args::parse $args withdef { - @id -id ::argparsingtest::test1_punkargs - @cmd -name argtest4 -help "test of punk::args::parse comparative performance" - @opts -anyopts 0 - -return -default string -type string - -frametype -default \uFFEF -type string - -show_edge -default \uFFEF -type string - -show_seps -default \uFFEF -type string - -join -type none -multiple 1 - -x -default "" -type string - -y -default b -type string - -z -default c -type string - -1 -default 1 -type boolean - -2 -default 2 -type integer - -3 -default 3 -type integer - @values - }] - return [tcl::dict::get $argd opts] - } - - punk::args::define { - @id -id ::test1_punkargs_by_id - @cmd -name argtest4 -help "test of punk::args::parse comparative performance" - @opts -anyopts 0 - -return -default string -type string - -frametype -default \uFFEF -type string - -show_edge -default \uFFEF -type string - -show_seps -default \uFFEF -type string - -join -type none -multiple 1 - -x -default "" -type string - -y -default b -type string - -z -default c -type string - -1 -default 1 -type boolean - -2 -default 2 -type integer - -3 -default 3 -type integer - @values - } - proc test1_punkargs_by_id {args} { - set argd [punk::args::get_by_id ::test1_punkargs_by_id $args] - return [tcl::dict::get $argd opts] - } - - punk::args::define { - @id -id ::argparsingtest::test1_punkargs2 - @cmd -name argtest4 -help "test of punk::args::parse comparative performance" - @leaders -min 0 -max 0 - @opts -anyopts 0 - -return -default string -type string - -frametype -default \uFFEF -type string - -show_edge -default \uFFEF -type string - -show_seps -default \uFFEF -type string - -join -type none -multiple 1 - -x -default "" -type string - -y -default b -type string - -z -default c -type string - -1 -default 1 -type boolean - -2 -default 2 -type integer - -3 -default 3 -type integer - @values -min 0 -max 0 - } - proc test1_punkargs2 {args} { - set argd [punk::args::parse $args withid ::argparsingtest::test1_punkargs2] - return [tcl::dict::get $argd opts] - } - - - proc test1_punkargs_validate_ansistripped {args} { - set argd [punk::args::parse $args withdef { - @id -id ::argparsingtest::test1_punkargs_validate_ansistripped - @cmd -name argtest4 -help "test of punk::args::parse comparative performance" - @opts -anyopts 0 - -return -default string -type string -choices {string object} -help "return type" - -frametype -default \uFFEF -type string - -show_edge -default \uFFEF -type string - -show_seps -default \uFFEF -type string - -join -type none -multiple 1 - -x -default "" -type string - -y -default b -type string - -z -default c -type string - -1 -default 1 -type boolean -validate_ansistripped true - -2 -default 2 -type integer -validate_ansistripped true - -3 -default 3 -type integer -validate_ansistripped true - @values - }] - return [tcl::dict::get $argd opts] - } - - package require opt - variable optlist - tcl::OptProc test1_opt { - {-return string "return type"} - {-frametype \uFFEF "type of frame"} - {-show_edge \uFFEF "show table outer borders"} - {-show_seps \uFFEF "show separators"} - {-join "solo option"} - {-x "" "x val"} - {-y b "y val"} - {-z c "z val"} - {-1 1 "1val"} - {-2 -int 2 "2val"} - {-3 -int 3 "3val"} - } { - set opts [dict create] - foreach v [info locals] { - dict set opts $v [set $v] - } - return $opts - } - - package require cmdline - #cmdline::getoptions is much faster than typedGetoptions - proc test1_cmdline_untyped {args} { - set cmdlineopts_untyped { - {return.arg "string" "return val"} - {frametype.arg \uFFEF "frame type"} - {show_edge.arg \uFFEF "show table borders"} - {show_seps.arg \uFFEF "show table seps"} - {join "join the things"} - {x.arg "" "arg x"} - {y.arg b "arg y"} - {z.arg c "arg z"} - {1.arg 1 "arg 1"} - {2.arg 2 "arg 2"} - {3.arg 3 "arg 3"} - } - - set usage "usage etc" - return [::cmdline::getoptions args $cmdlineopts_untyped $usage] - } - proc test1_cmdline_typed {args} { - set cmdlineopts_typed { - {return.arg "string" "return val"} - {frametype.arg \uFFEF "frame type"} - {show_edge.arg \uFFEF "show table borders"} - {show_seps.arg \uFFEF "show table seps"} - {join "join the things"} - {x.arg "" "arg x"} - {y.arg b "arg y"} - {z.arg c "arg z"} - {1.boolean 1 "arg 1"} - {2.integer 2 "arg 2"} - {3.integer 3 "arg 3"} - } - - set usage "usage etc" - return [::cmdline::typedGetoptions args $cmdlineopts_typed $usage] - } - - catch { - package require argp - argp::registerArgs test1_argp { - { -return string "string" } - { -frametype string \uFFEF } - { -show_edge string \uFFEF } - { -show_seps string \uFFEF } - { -x string "" } - { -y string b } - { -z string c } - { -1 boolean 1 } - { -2 integer 2 } - { -3 integer 3 } - } - } - proc test1_argp {args} { - argp::parseArgs opts - return [array get opts] - } - - package require tepam - tepam::procedure {test1_tepam} { - -args { - {-return -type string -default string} - {-frametype -type string -default \uFFEF} - {-show_edge -type string -default \uFFEF} - {-show_seps -type string -default \uFFEF} - {-join -type none -multiple} - {-x -type string -default ""} - {-y -type string -default b} - {-z -type string -default c} - {-1 -type boolean -default 1} - {-2 -type integer -default 2} - {-3 -type integer -default 3} - } - } { - return [dict create return $return frametype $frametype show_edge $show_edge show_seps $show_seps x $x y $y z $z 1 $1 2 $2 3 $3 join $join] - } - - #multiline values use first line of each record to determine amount of indent to trim - proc test_multiline {args} { - set t3 [textblock::frame t3] - set argd [punk::args::parse $args withdef [subst { - -template1 -default { - ****** - * t1 * - ****** - } - -template2 -default { ------ - ****** - * t2 * - ******} - -template3 -default {$t3} - #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately - -template3b -default { - $t3 - ----------------- - $t3 - abc\ndef - } - -template4 -default "****** - * t4 * - ******" - -template5 -default " - - - " - -flag -default 0 -type boolean - }]] - return $argd - } - proc test_multiline2 {args} { - set t3 [textblock::frame t3] - set argd [punk::args::parse $args withdef { - -template1 -default { - ****** - * t1 * - ****** - } - -template2 -default { ------ - ****** - * t2 * - ******} - -template3 -default {$t3} - #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately - -template3b -default { - ${$t3} - ----------------- - ${$t3} - abc\ndef - } - -template4 -default "****** - * t4 * - ******" - -template5 -default " - a - ${$t3} - c - " - -flag -default 0 -type boolean - }] - return $argd - } - - #proc sample1 {p1 n args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 - # #[para] Arguments: - # # [list_begin arguments] - # # [arg_def tring p1] A description of string argument p1. - # # [arg_def integer n] A description of integer argument n. - # # [list_end] - # return "ok" - #} - - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace argparsingtest ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval argparsingtest::lib { - namespace export {[a-z]*} ;# Convention: export all lowercase - namespace path [namespace parent] - #*** !doctools - #[subsection {Namespace argparsingtest::lib}] - #[para] Secondary functions that are part of the API - #[list_begin definitions] - - #proc utility1 {p1 args} { - # #*** !doctools - # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 - #} - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace argparsingtest::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -namespace eval argparsingtest::system { - #*** !doctools - #[subsection {Namespace argparsingtest::system}] - #[para] Internal functions that are not part of the API - - - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide argparsingtest [namespace eval argparsingtest { - variable pkg argparsingtest - variable version - set version 0.1.0 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/cksum-1.1.4.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/cksum-1.1.4.tm deleted file mode 100644 index 0fb17981..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/cksum-1.1.4.tm +++ /dev/null @@ -1,200 +0,0 @@ -# cksum.tcl - Copyright (C) 2002 Pat Thoyts -# -# Provides a Tcl only implementation of the unix cksum(1) command. This is -# similar to the sum(1) command but the algorithm is better defined and -# standardized across multiple platforms by POSIX 1003.2/D11.2 -# -# This command has been verified against the cksum command from the GNU -# textutils package version 2.0 -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- - -package require Tcl 8.5-; # tcl minimum version - -namespace eval ::crc { - namespace export cksum - - variable cksum_tbl [list 0x0 \ - 0x04C11DB7 0x09823B6E 0x0D4326D9 0x130476DC 0x17C56B6B \ - 0x1A864DB2 0x1E475005 0x2608EDB8 0x22C9F00F 0x2F8AD6D6 \ - 0x2B4BCB61 0x350C9B64 0x31CD86D3 0x3C8EA00A 0x384FBDBD \ - 0x4C11DB70 0x48D0C6C7 0x4593E01E 0x4152FDA9 0x5F15ADAC \ - 0x5BD4B01B 0x569796C2 0x52568B75 0x6A1936C8 0x6ED82B7F \ - 0x639B0DA6 0x675A1011 0x791D4014 0x7DDC5DA3 0x709F7B7A \ - 0x745E66CD 0x9823B6E0 0x9CE2AB57 0x91A18D8E 0x95609039 \ - 0x8B27C03C 0x8FE6DD8B 0x82A5FB52 0x8664E6E5 0xBE2B5B58 \ - 0xBAEA46EF 0xB7A96036 0xB3687D81 0xAD2F2D84 0xA9EE3033 \ - 0xA4AD16EA 0xA06C0B5D 0xD4326D90 0xD0F37027 0xDDB056FE \ - 0xD9714B49 0xC7361B4C 0xC3F706FB 0xCEB42022 0xCA753D95 \ - 0xF23A8028 0xF6FB9D9F 0xFBB8BB46 0xFF79A6F1 0xE13EF6F4 \ - 0xE5FFEB43 0xE8BCCD9A 0xEC7DD02D 0x34867077 0x30476DC0 \ - 0x3D044B19 0x39C556AE 0x278206AB 0x23431B1C 0x2E003DC5 \ - 0x2AC12072 0x128E9DCF 0x164F8078 0x1B0CA6A1 0x1FCDBB16 \ - 0x018AEB13 0x054BF6A4 0x0808D07D 0x0CC9CDCA 0x7897AB07 \ - 0x7C56B6B0 0x71159069 0x75D48DDE 0x6B93DDDB 0x6F52C06C \ - 0x6211E6B5 0x66D0FB02 0x5E9F46BF 0x5A5E5B08 0x571D7DD1 \ - 0x53DC6066 0x4D9B3063 0x495A2DD4 0x44190B0D 0x40D816BA \ - 0xACA5C697 0xA864DB20 0xA527FDF9 0xA1E6E04E 0xBFA1B04B \ - 0xBB60ADFC 0xB6238B25 0xB2E29692 0x8AAD2B2F 0x8E6C3698 \ - 0x832F1041 0x87EE0DF6 0x99A95DF3 0x9D684044 0x902B669D \ - 0x94EA7B2A 0xE0B41DE7 0xE4750050 0xE9362689 0xEDF73B3E \ - 0xF3B06B3B 0xF771768C 0xFA325055 0xFEF34DE2 0xC6BCF05F \ - 0xC27DEDE8 0xCF3ECB31 0xCBFFD686 0xD5B88683 0xD1799B34 \ - 0xDC3ABDED 0xD8FBA05A 0x690CE0EE 0x6DCDFD59 0x608EDB80 \ - 0x644FC637 0x7A089632 0x7EC98B85 0x738AAD5C 0x774BB0EB \ - 0x4F040D56 0x4BC510E1 0x46863638 0x42472B8F 0x5C007B8A \ - 0x58C1663D 0x558240E4 0x51435D53 0x251D3B9E 0x21DC2629 \ - 0x2C9F00F0 0x285E1D47 0x36194D42 0x32D850F5 0x3F9B762C \ - 0x3B5A6B9B 0x0315D626 0x07D4CB91 0x0A97ED48 0x0E56F0FF \ - 0x1011A0FA 0x14D0BD4D 0x19939B94 0x1D528623 0xF12F560E \ - 0xF5EE4BB9 0xF8AD6D60 0xFC6C70D7 0xE22B20D2 0xE6EA3D65 \ - 0xEBA91BBC 0xEF68060B 0xD727BBB6 0xD3E6A601 0xDEA580D8 \ - 0xDA649D6F 0xC423CD6A 0xC0E2D0DD 0xCDA1F604 0xC960EBB3 \ - 0xBD3E8D7E 0xB9FF90C9 0xB4BCB610 0xB07DABA7 0xAE3AFBA2 \ - 0xAAFBE615 0xA7B8C0CC 0xA379DD7B 0x9B3660C6 0x9FF77D71 \ - 0x92B45BA8 0x9675461F 0x8832161A 0x8CF30BAD 0x81B02D74 \ - 0x857130C3 0x5D8A9099 0x594B8D2E 0x5408ABF7 0x50C9B640 \ - 0x4E8EE645 0x4A4FFBF2 0x470CDD2B 0x43CDC09C 0x7B827D21 \ - 0x7F436096 0x7200464F 0x76C15BF8 0x68860BFD 0x6C47164A \ - 0x61043093 0x65C52D24 0x119B4BE9 0x155A565E 0x18197087 \ - 0x1CD86D30 0x029F3D35 0x065E2082 0x0B1D065B 0x0FDC1BEC \ - 0x3793A651 0x3352BBE6 0x3E119D3F 0x3AD08088 0x2497D08D \ - 0x2056CD3A 0x2D15EBE3 0x29D4F654 0xC5A92679 0xC1683BCE \ - 0xCC2B1D17 0xC8EA00A0 0xD6AD50A5 0xD26C4D12 0xDF2F6BCB \ - 0xDBEE767C 0xE3A1CBC1 0xE760D676 0xEA23F0AF 0xEEE2ED18 \ - 0xF0A5BD1D 0xF464A0AA 0xF9278673 0xFDE69BC4 0x89B8FD09 \ - 0x8D79E0BE 0x803AC667 0x84FBDBD0 0x9ABC8BD5 0x9E7D9662 \ - 0x933EB0BB 0x97FFAD0C 0xAFB010B1 0xAB710D06 0xA6322BDF \ - 0xA2F33668 0xBCB4666D 0xB8757BDA 0xB5365D03 0xB1F740B4 ] - - variable uid - if {![info exists uid]} {set uid 0} -} - -# crc::CksumInit -- -# -# Create and initialize a cksum context. This is cleaned up when we -# call CksumFinal to obtain the result. -# -proc ::crc::CksumInit {} { - variable uid - set token [namespace current]::[incr uid] - upvar #0 $token state - array set state {t 0 l 0} - return $token -} - -proc ::crc::CksumUpdate {token data} { - variable cksum_tbl - upvar #0 $token state - set t $state(t) - binary scan $data c* r - foreach {n} $r { - set index [expr { (($t >> 24) ^ ($n & 0xFF)) & 0xFF }] - # Since the introduction of built-in bigInt support with Tcl - # 8.5, bit-shifting $t to the left no longer overflows, - # keeping it 32 bits long. The value grows bigger and bigger - # instead - a severe hit on performance. For this reason we - # do a bitwise AND against 0xFFFFFFFF at each step to keep the - # value within limits. - set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] - incr state(l) - } - set state(t) $t - return -} - -proc ::crc::CksumFinal {token} { - variable cksum_tbl - upvar #0 $token state - set t $state(t) - for {set i $state(l)} {$i > 0} {set i [expr {$i>>8}]} { - set index [expr {(($t >> 24) ^ $i) & 0xFF}] - set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] - } - unset state - return [expr {~$t & 0xFFFFFFFF}] -} - -# crc::Pop -- -# -# Pop the nth element off a list. Used in options processing. -# -proc ::crc::Pop {varname {nth 0}} { - upvar $varname args - set r [lindex $args $nth] - set args [lreplace $args $nth $nth] - return $r -} - -# Description: -# Provide a Tcl equivalent of the unix cksum(1) command. -# Options: -# -filename name - return a checksum for the specified file. -# -format string - return the checksum using this format string. -# -chunksize size - set the chunking read size -# -proc ::crc::cksum {args} { - array set opts [list -filename {} -channel {} -chunksize 4096 \ - -format %u -command {}] - while {[string match -* [set option [lindex $args 0]]]} { - switch -glob -- $option { - -file* { set opts(-filename) [Pop args 1] } - -chan* { set opts(-channel) [Pop args 1] } - -chunk* { set opts(-chunksize) [Pop args 1] } - -for* { set opts(-format) [Pop args 1] } - -command { set opts(-command) [Pop args 1] } - default { - if {[llength $args] == 1} { break } - if {[string compare $option "--"] == 0} { Pop args ; break } - set err [join [lsort [array names opts -*]] ", "] - return -code error "bad option \"option\": must be $err" - } - } - Pop args - } - - if {$opts(-filename) != {}} { - set opts(-channel) [open $opts(-filename) r] - fconfigure $opts(-channel) -translation binary - } - - if {$opts(-channel) == {}} { - - if {[llength $args] != 1} { - return -code error "wrong # args: should be\ - cksum ?-format string?\ - -channel chan | -filename file | string" - } - set tok [CksumInit] - CksumUpdate $tok [lindex $args 0] - set r [CksumFinal $tok] - - } else { - - set tok [CksumInit] - while {![eof $opts(-channel)]} { - CksumUpdate $tok [read $opts(-channel) $opts(-chunksize)] - } - set r [CksumFinal $tok] - - if {$opts(-filename) != {}} { - close $opts(-channel) - } - } - - return [format $opts(-format) $r] -} - -# ------------------------------------------------------------------------- - -package provide cksum 1.1.4 - -# ------------------------------------------------------------------------- -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/cmdline-1.5.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/cmdline-1.5.2.tm deleted file mode 100644 index 4e5e1df9..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/cmdline-1.5.2.tm +++ /dev/null @@ -1,933 +0,0 @@ -# cmdline.tcl -- -# -# This package provides a utility for parsing command line -# arguments that are processed by our various applications. -# It also includes a utility routine to determine the -# application name for use in command line errors. -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# Copyright (c) 2001-2015 by Andreas Kupries . -# Copyright (c) 2003 by David N. Welton -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -package require Tcl 8.5- -package provide cmdline 1.5.2 - -namespace eval ::cmdline { - namespace export getArgv0 getopt getKnownOpt getfiles getoptions \ - getKnownOptions usage -} - -# ::cmdline::getopt -- -# -# The cmdline::getopt works in a fashion like the standard -# C based getopt function. Given an option string and a -# pointer to an array or args this command will process the -# first argument and return info on how to proceed. -# -# Arguments: -# argvVar Name of the argv list that you -# want to process. If options are found the -# arg list is modified and the processed arguments -# are removed from the start of the list. -# optstring A list of command options that the application -# will accept. If the option ends in ".arg" the -# getopt routine will use the next argument as -# an argument to the option. Otherwise the option -# is a boolean that is set to 1 if present. -# optVar The variable pointed to by optVar -# contains the option that was found (without the -# leading '-' and without the .arg extension). -# valVar Upon success, the variable pointed to by valVar -# contains the value for the specified option. -# This value comes from the command line for .arg -# options, otherwise the value is 1. -# If getopt fails, the valVar is filled with an -# error message. -# -# Results: -# The getopt function returns 1 if an option was found, 0 if no more -# options were found, and -1 if an error occurred. - -proc ::cmdline::getopt {argvVar optstring optVar valVar} { - upvar 1 $argvVar argsList - upvar 1 $optVar option - upvar 1 $valVar value - - set result [getKnownOpt argsList $optstring option value] - - if {$result < 0} { - # Collapse unknown-option error into any-other-error result. - set result -1 - } - return $result -} - -# ::cmdline::getKnownOpt -- -# -# The cmdline::getKnownOpt works in a fashion like the standard -# C based getopt function. Given an option string and a -# pointer to an array or args this command will process the -# first argument and return info on how to proceed. -# -# Arguments: -# argvVar Name of the argv list that you -# want to process. If options are found the -# arg list is modified and the processed arguments -# are removed from the start of the list. Note that -# unknown options and the args that follow them are -# left in this list. -# optstring A list of command options that the application -# will accept. If the option ends in ".arg" the -# getopt routine will use the next argument as -# an argument to the option. Otherwise the option -# is a boolean that is set to 1 if present. -# optVar The variable pointed to by optVar -# contains the option that was found (without the -# leading '-' and without the .arg extension). -# valVar Upon success, the variable pointed to by valVar -# contains the value for the specified option. -# This value comes from the command line for .arg -# options, otherwise the value is 1. -# If getopt fails, the valVar is filled with an -# error message. -# -# Results: -# The getKnownOpt function returns 1 if an option was found, -# 0 if no more options were found, -1 if an unknown option was -# encountered, and -2 if any other error occurred. - -proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} { - upvar 1 $argvVar argsList - upvar 1 $optVar option - upvar 1 $valVar value - - # default settings for a normal return - set value "" - set option "" - set result 0 - - # check if we're past the end of the args list - if {[llength $argsList] != 0} { - - # if we got -- or an option that doesn't begin with -, return (skipping - # the --). otherwise process the option arg. - switch -glob -- [set arg [lindex $argsList 0]] { - "--" { - set argsList [lrange $argsList 1 end] - } - "--*" - - "-*" { - set option [string range $arg 1 end] - if {[string equal [string range $option 0 0] "-"]} { - set option [string range $arg 2 end] - } - - # support for format: [-]-option=value - set idx [string first "=" $option 1] - if {$idx != -1} { - set _val [string range $option [expr {$idx+1}] end] - set option [string range $option 0 [expr {$idx-1}]] - } - - if {[lsearch -exact $optstring $option] != -1} { - # Booleans are set to 1 when present - set value 1 - set result 1 - set argsList [lrange $argsList 1 end] - } elseif {[lsearch -exact $optstring "$option.arg"] != -1} { - set result 1 - set argsList [lrange $argsList 1 end] - - if {[info exists _val]} { - set value $_val - } elseif {[llength $argsList]} { - set value [lindex $argsList 0] - set argsList [lrange $argsList 1 end] - } else { - set value "Option \"$option\" requires an argument" - set result -2 - } - } else { - # Unknown option. - set value "Illegal option \"-$option\"" - set result -1 - } - } - default { - # Skip ahead - } - } - } - - return $result -} - -# ::cmdline::getoptions -- -# -# Process a set of command line options, filling in defaults -# for those not specified. This also generates an error message -# that lists the allowed flags if an incorrect flag is specified. -# -# Arguments: -# argvVar The name of the argument list, typically argv. -# We remove all known options and their args from it. -# In other words, after the call to this command the -# referenced variable contains only the non-options, -# and unknown options. -# optlist A list-of-lists where each element specifies an option -# in the form: -# (where flag takes no argument) -# flag comment -# -# (or where flag takes an argument) -# flag default comment -# -# If flag ends in ".arg" then the value is taken from the -# command line. Otherwise it is a boolean and appears in -# the result if present on the command line. If flag ends -# in ".secret", it will not be displayed in the usage. -# usage Text to include in the usage display. Defaults to -# "options:" -# -# Results -# Name value pairs suitable for using with array set. -# A modified `argvVar`. - -proc ::cmdline::getoptions {argvVar optlist {usage options:}} { - upvar 1 $argvVar argv - - set opts [GetOptionDefaults $optlist result] - - set argc [llength $argv] - while {[set err [getopt argv $opts opt arg]]} { - if {$err < 0} { - set result(?) "" - break - } - set result($opt) $arg - } - if {[info exist result(?)] || [info exists result(help)]} { - Error [usage $optlist $usage] USAGE - } - return [array get result] -} - -# ::cmdline::getKnownOptions -- -# -# Process a set of command line options, filling in defaults -# for those not specified. This ignores unknown flags, but generates -# an error message that lists the correct usage if a known option -# is used incorrectly. -# -# Arguments: -# argvVar The name of the argument list, typically argv. This -# We remove all known options and their args from it. -# In other words, after the call to this command the -# referenced variable contains only the non-options, -# and unknown options. -# optlist A list-of-lists where each element specifies an option -# in the form: -# flag default comment -# If flag ends in ".arg" then the value is taken from the -# command line. Otherwise it is a boolean and appears in -# the result if present on the command line. If flag ends -# in ".secret", it will not be displayed in the usage. -# usage Text to include in the usage display. Defaults to -# "options:" -# -# Results -# Name value pairs suitable for using with array set. -# A modified `argvVar`. - -proc ::cmdline::getKnownOptions {argvVar optlist {usage options:}} { - upvar 1 $argvVar argv - - set opts [GetOptionDefaults $optlist result] - - # As we encounter them, keep the unknown options and their - # arguments in this list. Before we return from this procedure, - # we'll prepend these args to the argList so that the application - # doesn't lose them. - - set unknownOptions [list] - - set argc [llength $argv] - while {[set err [getKnownOpt argv $opts opt arg]]} { - if {$err == -1} { - # Unknown option. - - # Skip over any non-option items that follow it. - # For now, add them to the list of unknownOptions. - lappend unknownOptions [lindex $argv 0] - set argv [lrange $argv 1 end] - while {([llength $argv] != 0) \ - && ![string match "-*" [lindex $argv 0]]} { - lappend unknownOptions [lindex $argv 0] - set argv [lrange $argv 1 end] - } - } elseif {$err == -2} { - set result(?) "" - break - } else { - set result($opt) $arg - } - } - - # Before returning, prepend the any unknown args back onto the - # argList so that the application doesn't lose them. - set argv [concat $unknownOptions $argv] - - if {[info exist result(?)] || [info exists result(help)]} { - Error [usage $optlist $usage] USAGE - } - return [array get result] -} - -# ::cmdline::GetOptionDefaults -- -# -# This internal procedure processes the option list (that was passed to -# the getopt or getKnownOpt procedure). The defaultArray gets an index -# for each option in the option list, the value of which is the option's -# default value. -# -# Arguments: -# optlist A list-of-lists where each element specifies an option -# in the form: -# flag default comment -# If flag ends in ".arg" then the value is taken from the -# command line. Otherwise it is a boolean and appears in -# the result if present on the command line. If flag ends -# in ".secret", it will not be displayed in the usage. -# defaultArrayVar The name of the array in which to put argument defaults. -# -# Results -# Name value pairs suitable for using with array set. - -proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} { - upvar 1 $defaultArrayVar result - - set opts {? help} - foreach opt $optlist { - set name [lindex $opt 0] - if {[regsub -- {\.secret$} $name {} name] == 1} { - # Need to hide this from the usage display and getopt - } - lappend opts $name - if {[regsub -- {\.arg$} $name {} name] == 1} { - - # Set defaults for those that take values. - - set default [lindex $opt 1] - set result($name) $default - } else { - # The default for booleans is false - set result($name) 0 - } - } - return $opts -} - -# ::cmdline::usage -- -# -# Generate an error message that lists the allowed flags. -# -# Arguments: -# optlist As for cmdline::getoptions -# usage Text to include in the usage display. Defaults to -# "options:" -# -# Results -# A formatted usage message - -proc ::cmdline::usage {optlist {usage {options:}}} { - set str "[getArgv0] $usage\n" - set longest 20 - set lines {} - foreach opt [concat $optlist \ - {{- "Forcibly stop option processing"} {help "Print this message"} {? "Print this message"}}] { - set name "-[lindex $opt 0]" - if {[regsub -- {\.secret$} $name {} name] == 1} { - # Hidden option - continue - } - if {[regsub -- {\.arg$} $name {} name] == 1} { - append name " value" - set desc "[lindex $opt 2] <[lindex $opt 1]>" - } else { - set desc "[lindex $opt 1]" - } - set n [string length $name] - if {$n > $longest} { set longest $n } - # max not available before 8.5 - set longest [expr {max($longest, )}] - lappend lines $name $desc - } - foreach {name desc} $lines { - append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" - } - - return $str -} - -# ::cmdline::getfiles -- -# -# Given a list of file arguments from the command line, compute -# the set of valid files. On windows, file globbing is performed -# on each argument. On Unix, only file existence is tested. If -# a file argument produces no valid files, a warning is optionally -# generated. -# -# This code also uses the full path for each file. If not -# given it prepends [pwd] to the filename. This ensures that -# these files will never conflict with files in our zip file. -# -# Arguments: -# patterns The file patterns specified by the user. -# quiet If this flag is set, no warnings will be generated. -# -# Results: -# Returns the list of files that match the input patterns. - -proc ::cmdline::getfiles {patterns quiet} { - set result {} - if {$::tcl_platform(platform) == "windows"} { - foreach pattern $patterns { - set pat [file join $pattern] - set files [glob -nocomplain -- $pat] - if {$files == {}} { - if {! $quiet} { - puts stdout "warning: no files match \"$pattern\"" - } - } else { - foreach file $files { - lappend result $file - } - } - } - } else { - set result $patterns - } - set files {} - foreach file $result { - # Make file an absolute path so that we will never conflict - # with files that might be contained in our zip file. - set fullPath [file join [pwd] $file] - - if {[file isfile $fullPath]} { - lappend files $fullPath - } elseif {! $quiet} { - puts stdout "warning: no files match \"$file\"" - } - } - return $files -} - -# ::cmdline::getArgv0 -- -# -# This command returns the "sanitized" version of argv0. It will strip -# off the leading path and remove the ".bin" extensions that our apps -# use because they must be wrapped by a shell script. -# -# Arguments: -# None. -# -# Results: -# The application name that can be used in error messages. - -proc ::cmdline::getArgv0 {} { - global argv0 - - set name [file tail $argv0] - return [file rootname $name] -} - -## -# ### ### ### ######### ######### ######### -## -# Now the typed versions of the above commands. -## -# ### ### ### ######### ######### ######### -## - -# typedCmdline.tcl -- -# -# This package provides a utility for parsing typed command -# line arguments that may be processed by various applications. -# -# Copyright (c) 2000 by Ross Palmer Mohn. -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $ - -namespace eval ::cmdline { - namespace export typedGetopt typedGetoptions typedUsage - - # variable cmdline::charclasses -- - # - # Create regexp list of allowable character classes - # from "string is" error message. - # - # Results: - # String of character class names separated by "|" characters. - - variable charclasses - #checker exclude badKey - catch {string is . .} charclasses - variable dummy - regexp -- {must be (.+)$} $charclasses dummy charclasses - regsub -all -- {, (or )?} $charclasses {|} charclasses - unset dummy -} - -# ::cmdline::typedGetopt -- -# -# The cmdline::typedGetopt works in a fashion like the standard -# C based getopt function. Given an option string and a -# pointer to a list of args this command will process the -# first argument and return info on how to proceed. In addition, -# you may specify a type for the argument to each option. -# -# Arguments: -# argvVar Name of the argv list that you want to process. -# If options are found, the arg list is modified -# and the processed arguments are removed from the -# start of the list. -# -# optstring A list of command options that the application -# will accept. If the option ends in ".xxx", where -# xxx is any valid character class to the tcl -# command "string is", then typedGetopt routine will -# use the next argument as a typed argument to the -# option. The argument must match the specified -# character classes (e.g. integer, double, boolean, -# xdigit, etc.). Alternatively, you may specify -# ".arg" for an untyped argument. -# -# optVar Upon success, the variable pointed to by optVar -# contains the option that was found (without the -# leading '-' and without the .xxx extension). If -# typedGetopt fails the variable is set to the empty -# string. SOMETIMES! Different for each -value! -# -# argVar Upon success, the variable pointed to by argVar -# contains the argument for the specified option. -# If typedGetopt fails, the variable is filled with -# an error message. -# -# Argument type syntax: -# Option that takes no argument. -# foo -# -# Option that takes a typeless argument. -# foo.arg -# -# Option that takes a typed argument. Allowable types are all -# valid character classes to the tcl command "string is". -# Currently must be one of alnum, alpha, ascii, control, -# boolean, digit, double, false, graph, integer, lower, print, -# punct, space, true, upper, wordchar, or xdigit. -# foo.double -# -# Option that takes an argument from a list. -# foo.(bar|blat) -# -# Argument quantifier syntax: -# Option that takes an optional argument. -# foo.arg? -# -# Option that takes a list of arguments terminated by "--". -# foo.arg+ -# -# Option that takes an optional list of arguments terminated by "--". -# foo.arg* -# -# Argument quantifiers work on all argument types, so, for -# example, the following is a valid option specification. -# foo.(bar|blat|blah)? -# -# Argument syntax miscellany: -# Options may be specified on the command line using a unique, -# shortened version of the option name. Given that program foo -# has an option list of {bar.alpha blah.arg blat.double}, -# "foo -b fob" returns an error, but "foo -ba fob" -# successfully returns {bar fob} -# -# Results: -# The typedGetopt function returns one of the following: -# 1 a valid option was found -# 0 no more options found to process -# -1 invalid option -# -2 missing argument to a valid option -# -3 argument to a valid option does not match type -# -# Known Bugs: -# When using options which include special glob characters, -# you must use the exact option. Abbreviating it can cause -# an error in the "cmdline::prefixSearch" procedure. - -proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} { - variable charclasses - - upvar $argvVar argsList - - upvar $optVar retvar - upvar $argVar optarg - - # default settings for a normal return - set optarg "" - set retvar "" - set retval 0 - - # check if we're past the end of the args list - if {[llength $argsList] != 0} { - - # if we got -- or an option that doesn't begin with -, return (skipping - # the --). otherwise process the option arg. - switch -glob -- [set arg [lindex $argsList 0]] { - "--" { - set argsList [lrange $argsList 1 end] - } - - "-*" { - # Create list of options without their argument extensions - - set optstr "" - foreach str $optstring { - lappend optstr [file rootname $str] - } - - set _opt [string range $arg 1 end] - - set i [prefixSearch $optstr [file rootname $_opt]] - if {$i != -1} { - set opt [lindex $optstring $i] - - set quantifier "none" - if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} { - set opt [string range $opt 0 end-1] - } - - if {[string first . $opt] == -1} { - set retval 1 - set retvar $opt - set argsList [lrange $argsList 1 end] - - } elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass] - || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} { - if {[string equal arg $charclass]} { - set type arg - } elseif {[regexp -- "^($charclasses)\$" $charclass]} { - set type class - } else { - set type oneof - } - - set argsList [lrange $argsList 1 end] - set opt [file rootname $opt] - - while {1} { - if {[llength $argsList] == 0 - || [string equal "--" [lindex $argsList 0]]} { - if {[string equal "--" [lindex $argsList 0]]} { - set argsList [lrange $argsList 1 end] - } - - set oneof "" - if {$type == "arg"} { - set charclass an - } elseif {$type == "oneof"} { - set oneof ", one of $charclass" - set charclass an - } - - if {$quantifier == "?"} { - set retval 1 - set retvar $opt - set optarg "" - } elseif {$quantifier == "+"} { - set retvar $opt - if {[llength $optarg] < 1} { - set retval -2 - set optarg "Option requires at least one $charclass argument$oneof -- $opt" - } else { - set retval 1 - } - } elseif {$quantifier == "*"} { - set retval 1 - set retvar $opt - } else { - set optarg "Option requires $charclass argument$oneof -- $opt" - set retvar $opt - set retval -2 - } - set quantifier "" - } elseif {($type == "arg") - || (($type == "oneof") - && [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1) - || (($type == "class") - && [string is $charclass [lindex $argsList 0]])} { - set retval 1 - set retvar $opt - lappend optarg [lindex $argsList 0] - set argsList [lrange $argsList 1 end] - } else { - set oneof "" - if {$type == "arg"} { - set charclass an - } elseif {$type == "oneof"} { - set oneof ", one of $charclass" - set charclass an - } - set optarg "Option requires $charclass argument$oneof -- $opt" - set retvar $opt - set retval -3 - - if {$quantifier == "?"} { - set retval 1 - set optarg "" - } - set quantifier "" - } - if {![regexp -- {[+*]} $quantifier]} { - break; - } - } - } else { - Error \ - "Illegal option type specification: must be one of $charclasses" \ - BAD OPTION TYPE - } - } else { - set optarg "Illegal option -- $_opt" - set retvar $_opt - set retval -1 - } - } - default { - # Skip ahead - } - } - } - - return $retval -} - -# ::cmdline::typedGetoptions -- -# -# Process a set of command line options, filling in defaults -# for those not specified. This also generates an error message -# that lists the allowed options if an incorrect option is -# specified. -# -# Arguments: -# argvVar The name of the argument list, typically argv -# optlist A list-of-lists where each element specifies an option -# in the form: -# -# option default comment -# -# Options formatting is as described for the optstring -# argument of typedGetopt. Default is for optionally -# specifying a default value. Comment is for optionally -# specifying a comment for the usage display. The -# options "--", "-help", and "-?" are automatically included -# in optlist. -# -# Argument syntax miscellany: -# Options formatting and syntax is as described in typedGetopt. -# There are two additional suffixes that may be applied when -# passing options to typedGetoptions. -# -# You may add ".multi" as a suffix to any option. For options -# that take an argument, this means that the option may be used -# more than once on the command line and that each additional -# argument will be appended to a list, which is then returned -# to the application. -# foo.double.multi -# -# If a non-argument option is specified as ".multi", it is -# toggled on and off for each time it is used on the command -# line. -# foo.multi -# -# If an option specification does not contain the ".multi" -# suffix, it is not an error to use an option more than once. -# In this case, the behavior for options with arguments is that -# the last argument is the one that will be returned. For -# options that do not take arguments, using them more than once -# has no additional effect. -# -# Options may also be hidden from the usage display by -# appending the suffix ".secret" to any option specification. -# Please note that the ".secret" suffix must be the last suffix, -# after any argument type specification and ".multi" suffix. -# foo.xdigit.multi.secret -# -# Results -# Name value pairs suitable for using with array set. - -proc ::cmdline::typedGetoptions {argvVar optlist {usage options:}} { - variable charclasses - - upvar 1 $argvVar argv - - set opts {? help} - foreach opt $optlist { - set name [lindex $opt 0] - if {[regsub -- {\.secret$} $name {} name] == 1} { - # Remove this extension before passing to typedGetopt. - } - if {[regsub -- {\.multi$} $name {} name] == 1} { - # Remove this extension before passing to typedGetopt. - - regsub -- {\..*$} $name {} temp - set multi($temp) 1 - } - lappend opts $name - if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} { - # Set defaults for those that take values. - # Booleans are set just by being present, or not - - set dflt [lindex $opt 1] - if {$dflt != {}} { - set defaults($name) $dflt - } - } - } - set argc [llength $argv] - while {[set err [typedGetopt argv $opts opt arg]]} { - if {$err == 1} { - if {[info exists result($opt)] - && [info exists multi($opt)]} { - # Toggle boolean options or append new arguments - - if {$arg == ""} { - unset result($opt) - } else { - set result($opt) "$result($opt) $arg" - } - } else { - set result($opt) "$arg" - } - } elseif {($err == -1) || ($err == -3)} { - Error [typedUsage $optlist $usage] USAGE - } elseif {$err == -2 && ![info exists defaults($opt)]} { - Error [typedUsage $optlist $usage] USAGE - } - } - if {[info exists result(?)] || [info exists result(help)]} { - Error [typedUsage $optlist $usage] USAGE - } - foreach {opt dflt} [array get defaults] { - if {![info exists result($opt)]} { - set result($opt) $dflt - } - } - return [array get result] -} - -# ::cmdline::typedUsage -- -# -# Generate an error message that lists the allowed flags, -# type of argument taken (if any), default value (if any), -# and an optional description. -# -# Arguments: -# optlist As for cmdline::typedGetoptions -# -# Results -# A formatted usage message - -proc ::cmdline::typedUsage {optlist {usage {options:}}} { - variable charclasses - - set str "[getArgv0] $usage\n" - set longest 20 - set lines {} - foreach opt [concat $optlist \ - {{help "Print this message"} {? "Print this message"}}] { - set name "-[lindex $opt 0]" - if {[regsub -- {\.secret$} $name {} name] == 1} { - # Hidden option - continue - } - - if {[regsub -- {\.multi$} $name {} name] == 1} { - # Display something about multiple options - } - - if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass] || - [regexp -- {\.\(([^)]+)\)} $opt dummy charclass] - } { - regsub -- "\\..+\$" $name {} name - append name " $charclass" - set desc [lindex $opt 2] - set default [lindex $opt 1] - if {$default != ""} { - append desc " <$default>" - } - } else { - set desc [lindex $opt 1] - } - lappend accum $name $desc - set n [string length $name] - if {$n > $longest} { set longest $n } - # max not available before 8.5 - set longest [expr {max($longest, [string length $name])}] - } - foreach {name desc} $accum { - append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" - } - return $str -} - -# ::cmdline::prefixSearch -- -# -# Search a Tcl list for a pattern; searches first for an exact match, -# and if that fails, for a unique prefix that matches the pattern -# (i.e, first "lsearch -exact", then "lsearch -glob $pattern*" -# -# Arguments: -# list list of words -# pattern word to search for -# -# Results: -# Index of found word is returned. If no exact match or -# unique short version is found then -1 is returned. - -proc ::cmdline::prefixSearch {list pattern} { - # Check for an exact match - - if {[set pos [::lsearch -exact $list $pattern]] > -1} { - return $pos - } - - # Check for a unique short version - - set slist [lsort $list] - if {[set pos [::lsearch -glob $slist $pattern*]] > -1} { - # What if there is nothing for the check variable? - - set check [lindex $slist [expr {$pos + 1}]] - if {[string first $pattern $check] != 0} { - return [::lsearch -exact $list [lindex $slist $pos]] - } - } - return -1 -} -# ::cmdline::Error -- -# -# Internal helper to throw errors with a proper error-code attached. -# -# Arguments: -# message text of the error message to throw. -# args additional parts of the error code to use, -# with CMDLINE as basic prefix added by this command. -# -# Results: -# An error is thrown, always. - -proc ::cmdline::Error {message args} { - return -code error -errorcode [linsert $args 0 CMDLINE] $message -} diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm deleted file mode 100644 index b2561a20..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm +++ /dev/null @@ -1,518 +0,0 @@ - - -#JMN 2021 - Public Domain -#cooperative command renaming -# -# REVIEW 2024 - code was originally for specific use in packageTrace -# - code should be reviewed for more generic utility. -# - API is obscure and undocumented. -# - unclear if intention was only for builtins -# - consider use of newer 'info cmdtype' - (but need also support for safe interps) -# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack. -# - document that replacement command should use 'commandstack::get_next_command ' for delegating to command as it was prior to rename -#changes: -#2024 -# - mungecommand to support namespaced commands -# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ -#2021-09-18 -# - initial version -# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command -# - They need to be able to load and unload in any order. -# - -#strive for no other package dependencies here. - - -namespace eval commandstack { - variable all_stacks - variable debug - set debug 0 - variable known_renamers [list ::packagetrace ::packageSuppress] - if {![info exists all_stacks]} { - #don't wipe it - set all_stacks [dict create] - } -} - -namespace eval commandstack::util { - #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages. - #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace - #A magic comment was chosen as the identifying method. - #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc. - - #return unspecified if the command is a proc with a body but no magic comment ID - #return unknown if the command doesn't have a proc body to analyze - #otherwise return the package name identified in the magic comment - proc get_IMPLEMENTOR {command} { - #assert - command has already been resolved to a namespace ie fully qualified - if {[llength [info procs $command]]} { - #look for *IMPLEMENTOR_*! - set prefix IMPLEMENTOR_ - set suffix "!" - set body [uplevel 1 [list info body $command]] - if {[string match "*$prefix*$suffix*" $body]} { - set prefixposn [string first "$prefix" $body] - set pkgposn [expr {$prefixposn + [string length $prefix]}] - #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]] - set suffixposn [string first $suffix $body $pkgposn] - return [string range $body $pkgposn $suffixposn-1] - } else { - return unspecified - } - } else { - if {[info commands tcl::info::cmdtype] ne ""} { - #tcl9 and maybe some tcl 8.7s ? - switch -- [tcl::info::cmdtype $command] { - native { - return builtin - } - default { - return undetermined - } - } - } else { - return undetermined - } - } - } -} -namespace eval commandstack::renamed_commands {} -namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place - -namespace eval commandstack { - namespace export {[a-z]*} - proc help {} { - return { - - } - } - - proc debug {{on_off {}}} { - variable debug - if {$on_off eq ""} { - return $debug - } else { - if {[string is boolean -strict $debug]} { - set debug [expr {$on_off && 1}] - return $debug - } - } - } - - proc get_stack {{command ""}} { - variable all_stacks - if {$command eq ""} { - return $all_stacks - } - set command [uplevel 1 [list namespace which $command]] - if {[dict exists $all_stacks $command]} { - return [dict get $all_stacks $command] - } else { - return [list] - } - } - - #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to. - #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs? - #e.g if renaming builtin 'package' - this command is generally called 'a lot' - proc get_next_command {command renamer tokenid} { - variable all_stacks - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - #stack is a list of dicts, 1st entry is token { } - set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] - if {$posn > -1} { - set record [lindex $stack $posn] - return [dict get $record implementation] - } else { - error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" - } - } else { - return $command - } - } - proc basecall {command args} { - variable all_stacks - set command [uplevel 1 [list namespace which $command]] - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - if {[llength $stack]} { - set rec1 [lindex $stack 0] - tailcall [dict get $rec1 implementation] {*}$args - } else { - tailcall $command {*}$args - } - } else { - tailcall $command {*}$args - } - } - - - #review. - # defaults to calling namespace - but can be arbitrary string - proc rename_command {args} { - #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames - # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack - # - if {[lindex $args 0] eq "-renamer"} { - set renamer [lindex $args 1] - set arglist [lrange $args 2 end] - } else { - set renamer "" - set arglist $args - } - if {[llength $arglist] != 3} { - error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" - } - lassign $arglist command procargs procbody - - set command [uplevel 1 [list namespace which $command]] - set mungedcommand [string map {:: _ns_} $command] - set mungedrenamer [string map {:: _ns_} $renamer] - variable all_stacks - variable known_renamers - variable renamer_command_tokens ;#monotonically increasing int per :: representing number of renames ever done. - if {$renamer eq ""} { - set renamer [uplevel 1 [list namespace current]] - } - if {$renamer ni $known_renamers} { - lappend known_renamers $renamer - dict set renamer_command_tokens [list $renamer $command] 0 - } - - #TODO - reduce emissions to stderr - flag for debug? - - #e.g packageTrace and packageSuppress packages use this convention. - set nextinfo [uplevel 1 [list\ - apply {{command renamer procbody} { - #todo - munge dash so we can make names in renamed_commands separable - # {- _dash_} ? - set mungedcommand [string map {:: _ns_} $command] - set mungedrenamer [string map {:: _ns_} $renamer] - set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1] - set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. - set do_rename 0 - if {[llength [info procs $command]] || [llength [info commands $next_target]]} { - #$command is not the standard builtin - something has replaced it, could be ourself. - set next_implementor [::commandstack::util::get_IMPLEMENTOR $command] - set munged_next_implementor [string map {:: _ns_} $next_implementor] - #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it. - if {[dict exists $::commandstack::all_stacks $command]} { - set comstacks [dict get $::commandstack::all_stacks $command] - } else { - set comstacks [list] - } - set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer') - if {[llength $this_renamer_previous_entries]} { - if {$next_implementor eq $renamer} { - #previous renamer was us. Rather than assume our job is done.. compare the implementations - #don't rename if immediate predecessor is same code. - #set topstack [lindex $comstacks end] - #set next_impl [dict get $topstack implementation] - set current_body [info body $command] - lassign [commandstack::lib::split_body $current_body] _ current_code - set current_code [string trim $current_code] - set new_code [string trim $procbody] - if {$current_code eq $new_code} { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." - puts stderr [::commandstack::show_stack $command] - } else { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." - puts stdout "----------" - puts stdout "$current_code" - puts stdout "----------" - puts stdout "$new_code" - puts stdout "----------" - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } else { - puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" - puts stderr - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } elseif {$next_implementor in $::commandstack::known_renamers} { - set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } elseif {$next_implementor in {builtin}} { - #native/builtin could still have been renamed - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } elseif {$next_implementor in {unspecified undetermined}} { - #could be a standard tcl proc, or from application or package - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } else { - puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" - set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid - set do_rename 1 - } - } else { - #_originalcommand_ - #assume builtin/original - set next_implementor original - #rename $command $next_target - set do_rename 1 - } - #There are of course other ways in which $command may have been renamed - but we can't detect. - set token [list $command $renamer $tokenid] - return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] - } } $command $renamer $procbody] - ] - - - variable debug - if {$debug} { - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]" - } else { - #assume this is the original - puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]" - } - } - - #token is always first dict entry. (Value needs to be searched with lsearch -index 1 ) - #renamer is always second dict entry (Value needs to be searched with lsearch -index 3) - set new_record [dict create\ - token [dict get $nextinfo token]\ - renamer $renamer\ - next_implementor [dict get $nextinfo next_implementor]\ - next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\ - implementation [dict get $nextinfo next_target]\ - ] - if {![dict get $nextinfo do_rename]} { - #review - puts stderr "no rename performed" - return [dict create implementation ""] - } - catch {rename ::commandstack::temp::testproc ""} - set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { - #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) - set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. - set COMMANDSTACKNEXT [%next_getter%] - ## - }] - set final_procbody "$nextinit$procbody" - #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command - #(e.g due to invalid argument specifiers) - proc ::commandstack::temp::testproc $procargs $final_procbody - uplevel 1 [list rename $command [dict get $nextinfo next_target]] - uplevel 1 [list rename ::commandstack::temp::testproc $command] - dict lappend all_stacks $command $new_record - - - return $new_record - } - - #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer - #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost - #todo - removal of all entries pertaining to a particular renamer - #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? - - #remove by token, or by commandname if called from same context as original rename_command - #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. - #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything. - #similarly a nonexistant token or renamer will not remove anything and will just return the current stack - proc remove_rename {token_or_command} { - if {[llength $token_or_command] == 3} { - #is token - lassign $token_or_command command renamer tokenid - } elseif {[llength $token_or_command] == 2} { - #command and renamer only supplied - lassign $token_or_command command renamer - set tokenid "" - } elseif {[llength $token_or_command] == 1} { - #is command name only - set command $token_or_command - set renamer [uplevel 1 [list namespace current]] - set tokenid "" - } - set command [uplevel 1 [list namespace which $command]] - variable all_stacks - variable known_renamers - if {$renamer ni $known_renamers} { - error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" - } - if {[dict exists $all_stacks $command]} { - set stack [dict get $all_stacks $command] - if {$tokenid ne ""} { - #token_or_command is a token as returned within the rename_command result dictionary - #search first dict value - set doomed_posn [lsearch -index 1 $stack $token_or_command] - } else { - #search second dict value - set matches [lsearch -all -index 3 $stack $renamer] - set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer - } - if {$doomed_posn ne "" && $doomed_posn > -1} { - set doomed_record [lindex $stack $doomed_posn] - if {[llength $stack] == ($doomed_posn + 1)} { - #last on stack - put the implemenation from the doomed_record back as the actual command - uplevel #0 [list rename $command ""] - uplevel #0 [list rename [dict get $doomed_record implementation] $command] - } elseif {[llength $stack] > ($doomed_posn + 1)} { - #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed - set rewrite_posn [expr {$doomed_posn + 1}] - set rewrite_record [lindex $stack $rewrite_posn] - - if {[dict get $rewrite_record next_implementor] ne $renamer} { - puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]" - } else { - uplevel #0 [list rename [dict get $rewrite_record implementation] ""] - } - dict set rewrite_record next_implementor [dict get $doomed_record next_implementor] - #don't update next_getter - it always refers to self - dict set rewrite_record implementation [dict get $doomed_record implementation] - lset stack $rewrite_posn $rewrite_record - dict set all_stacks $command $stack - } - set stack [lreplace $stack $doomed_posn $doomed_posn] - dict set all_stacks $command $stack - - } - return $stack - } - return [list] - } - - proc show_stack {{commandname_glob *}} { - variable all_stacks - if {![regexp {[?*]} $commandname_glob]} { - #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace - set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] - } - if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { - #punk pipeline also needed for patterns - return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] - } else { - set result "" - set matchedkeys [dict keys $all_stacks $commandname_glob] - #don't try to calculate widest on empty list - if {[llength $matchedkeys]} { - set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] - set indent [string repeat " " [expr {$widest + 3}]] - set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide - set padkey [string repeat " " 20] - foreach k $matchedkeys { - append result "$k = " - set i 0 - foreach stackmember [dict get $all_stacks $k] { - if {$i > 0} { - append result "\n$indent" - } - append result [string range "$i " 0 4] " = " - set j 0 - dict for {k v} $stackmember { - if {$j > 0} { - append result "\n$indent2" - } - set displaykey [string range "$k$padkey" 0 20] - append result "$displaykey = $v" - incr j - } - incr i - } - append result \n - } - } - return $result - } - } - - #review - #document when this is to be called. Wiping stacks without undoing renames seems odd. - proc Delete_stack {command} { - variable all_stacks - if {[dict exists $all_stacks $command]} { - dict unset all_stacks $command - return 1 - } else { - return 1 - } - } - - #can be used to temporarily put a stack aside - should manually rename back when done. - #review - document how/when to use. example? intention? - proc Rename_stack {oldname newname} { - variable all_stacks - if {[dict exists $all_stacks $oldname]} { - if {[dict exists $all_stacks $newname]} { - error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" - } else { - #set stackval [dict get $all_stacks $oldname] - #dict unset all_stacks $oldname - #dict set all_stacks $newname $stackval - dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0] - } - } - } -} - - - - - - - - -namespace eval commandstack::lib { - proc splitx {str {regexp {[\t \r\n]+}}} { - #snarfed from tcllib textutil::splitx to avoid the dependency - # Bugfix 476988 - if {[string length $str] == 0} { - return {} - } - if {[string length $regexp] == 0} { - return [::split $str ""] - } - if {[regexp $regexp {}]} { - return -code error "splitting on regexp \"$regexp\" would cause infinite loop" - } - - set list {} - set start 0 - while {[regexp -start $start -indices -- $regexp $str match submatch]} { - foreach {subStart subEnd} $submatch break - foreach {matchStart matchEnd} $match break - incr matchStart -1 - incr matchEnd - lappend list [string range $str $start $matchStart] - if {$subStart >= $start} { - lappend list [string range $str $subStart $subEnd] - } - set start $matchEnd - } - lappend list [string range $str $start end] - return $list - } - proc split_body {procbody} { - set marker "##" - set header "" - set code "" - set found_marker 0 - foreach ln [split $procbody \n] { - if {!$found_marker} { - if {[string trim $ln] eq $marker} { - set found_marker 1 - } else { - append header $ln \n - } - } else { - append code $ln \n - } - } - if {$found_marker} { - return [list $header $code] - } else { - return [list "" $procbody] - } - } -} - -package provide commandstack [namespace eval commandstack { - set version 0.3 -}] - - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/debug-1.0.6.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/debug-1.0.6.tm deleted file mode 100644 index c2ee57be..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/debug-1.0.6.tm +++ /dev/null @@ -1,306 +0,0 @@ -# Debug - a debug narrative logger. -# -- Colin McCormack / originally Wub server utilities -# -# Debugging areas of interest are represented by 'tokens' which have -# independantly settable levels of interest (an integer, higher is more detailed) -# -# Debug narrative is provided as a tcl script whose value is [subst]ed in the -# caller's scope if and only if the current level of interest matches or exceeds -# the Debug call's level of detail. This is useful, as one can place arbitrarily -# complex narrative in code without unnecessarily evaluating it. -# -# TODO: potentially different streams for different areas of interest. -# (currently only stderr is used. there is some complexity in efficient -# cross-threaded streams.) - -# # ## ### ##### ######## ############# ##################### -## Requisites - -package require Tcl 8.5- - -namespace eval ::debug { - namespace export -clear \ - define on off prefix suffix header trailer \ - names 2array level setting parray pdict \ - nl tab hexl - namespace ensemble create -subcommands {} -} - -# # ## ### ##### ######## ############# ##################### -## API & Implementation - -proc ::debug::noop {args} {} - -proc ::debug::debug {tag message {level 1}} { - variable detail - if {$detail($tag) < $level} { - #puts stderr "$tag @@@ $detail($tag) >= $level" - return - } - - variable prefix - variable suffix - variable header - variable trailer - variable fds - - if {[info exists fds($tag)]} { - set fd $fds($tag) - } else { - set fd stderr - } - - # Assemble the shown text from the user message and the various - # prefixes and suffices (global + per-tag). - - set themessage "" - if {[info exists prefix(::)]} { append themessage $prefix(::) } - if {[info exists prefix($tag)]} { append themessage $prefix($tag) } - append themessage $message - if {[info exists suffix($tag)]} { append themessage $suffix($tag) } - if {[info exists suffix(::)]} { append themessage $suffix(::) } - - # Resolve variables references and command invokations embedded - # into the message with plain text. - set code [catch { - set smessage [uplevel 1 [list ::subst -nobackslashes $themessage]] - set sheader [uplevel 1 [list ::subst -nobackslashes $header]] - set strailer [uplevel 1 [list ::subst -nobackslashes $trailer]] - } __ eo] - - # And dump an internal error if that resolution failed. - if {$code} { - if {[catch { - set caller [info level -1] - }]} { set caller GLOBAL } - if {[string length $caller] >= 1000} { - set caller "[string range $caller 0 200]...[string range $caller end-200 end]" - } - foreach line [split $caller \n] { - puts -nonewline $fd "@@(DebugError from $tag ($eo): $line)" - } - return - } - - # From here we have a good message to show. We only shorten it a - # bit if its a bit excessive in size. - - if {[string length $smessage] > 4096} { - set head [string range $smessage 0 2048] - set tail [string range $smessage end-2048 end] - set smessage "${head}...(truncated)...$tail" - } - - foreach line [split $smessage \n] { - puts $fd "$sheader$tag | $line$strailer" - } - return -} - -# names - return names of debug tags -proc ::debug::names {} { - variable detail - return [lsort [array names detail]] -} - -proc ::debug::2array {} { - variable detail - set result {} - foreach n [lsort [array names detail]] { - if {[interp alias {} debug.$n] ne "::debug::noop"} { - lappend result $n $detail($n) - } else { - lappend result $n -$detail($n) - } - } - return $result -} - -# level - set level and fd for tag -proc ::debug::level {tag {level ""} {fd {}}} { - variable detail - # TODO: Force level >=0. - if {$level ne ""} { - set detail($tag) $level - } - - if {![info exists detail($tag)]} { - set detail($tag) 1 - } - - variable fds - if {$fd ne {}} { - set fds($tag) $fd - } - - return $detail($tag) -} - -proc ::debug::header {text} { variable header $text } -proc ::debug::trailer {text} { variable trailer $text } - -proc ::debug::define {tag} { - if {[interp alias {} debug.$tag] ne {}} return - off $tag - return -} - -# Set a prefix/suffix to use for tag. -# The global (tag-independent) prefix/suffix is adressed through tag '::'. -# This works because colon (:) is an illegal character for user-specified tags. - -proc ::debug::prefix {tag {theprefix {}}} { - variable prefix - set prefix($tag) $theprefix - - if {[interp alias {} debug.$tag] ne {}} return - off $tag - return -} - -proc ::debug::suffix {tag {theprefix {}}} { - variable suffix - set suffix($tag) $theprefix - - if {[interp alias {} debug.$tag] ne {}} return - off $tag - return -} - -# turn on debugging for tag -proc ::debug::on {tag {level ""} {fd {}}} { - variable active - set active($tag) 1 - level $tag $level $fd - interp alias {} debug.$tag {} ::debug::debug $tag - return -} - -# turn off debugging for tag -proc ::debug::off {tag {level ""} {fd {}}} { - variable active - set active($tag) 1 - level $tag $level $fd - interp alias {} debug.$tag {} ::debug::noop - return -} - -proc ::debug::setting {args} { - if {[llength $args] == 1} { - set args [lindex $args 0] - } - set fd stderr - if {[llength $args] % 2} { - set fd [lindex $args end] - set args [lrange $args 0 end-1] - } - foreach {tag level} $args { - if {$level > 0} { - level $tag $level $fd - interp alias {} debug.$tag {} ::debug::debug $tag - } else { - level $tag [expr {-$level}] $fd - interp alias {} debug.$tag {} ::debug::noop - } - } - return -} - -# # ## ### ##### ######## ############# ##################### -## Convenience commands. -# Format arrays and dicts as multi-line message. -# Insert newlines and tabs. - -proc ::debug::nl {} { return \n } -proc ::debug::tab {} { return \t } - -proc ::debug::parray {a {pattern *}} { - upvar 1 $a array - if {![array exists array]} { - error "\"$a\" isn't an array" - } - pdict [array get array] $pattern -} - -proc ::debug::pdict {dict {pattern *}} { - set maxl 0 - set names [lsort -dict [dict keys $dict $pattern]] - foreach name $names { - if {[string length $name] > $maxl} { - set maxl [string length $name] - } - } - set maxl [expr {$maxl + 2}] - set lines {} - foreach name $names { - set nameString [format (%s) $name] - lappend lines [format "%-*s = %s" \ - $maxl $nameString \ - [dict get $dict $name]] - } - return [join $lines \n] -} - -proc ::debug::hexl {data {prefix {}}} { - set r {} - - # Convert the data to hex and to characters. - binary scan $data H*@0a* hexa asciia - - # Replace non-printing characters in the data with dots. - regsub -all -- {[^[:graph:] ]} $asciia {.} asciia - - # Pad with spaces to a full multiple of 32/16. - set n [expr {[string length $hexa] % 32}] - if {$n < 32} { append hexa [string repeat { } [expr {32-$n}]] } - #puts "pad H [expr {32-$n}]" - - set n [expr {[string length $asciia] % 32}] - if {$n < 16} { append asciia [string repeat { } [expr {16-$n}]] } - #puts "pad A [expr {32-$n}]" - - # Reassemble formatted, in groups of 16 bytes/characters. - # The hex part is handled in groups of 32 nibbles. - set addr 0 - while {[string length $hexa]} { - # Get front group of 16 bytes each. - set hex [string range $hexa 0 31] - set ascii [string range $asciia 0 15] - # Prep for next iteration - set hexa [string range $hexa 32 end] - set asciia [string range $asciia 16 end] - - # Convert the hex to pairs of hex digits - regsub -all -- {..} $hex {& } hex - - # Add the hex and latin-1 data to the result buffer - append r $prefix [format %04x $addr] { | } $hex { |} $ascii |\n - incr addr 16 - } - - # And done - return $r -} - -# # ## ### ##### ######## ############# ##################### - -namespace eval debug { - variable detail ; # map: TAG -> level of interest - variable prefix ; # map: TAG -> message prefix to use - variable suffix ; # map: TAG -> message suffix to use - variable fds ; # map: TAG -> handle of open channel to log to. - variable header {} ; # per-line heading, subst'ed - variable trailer {} ; # per-line ending, subst'ed - - # Notes: - # - The tag '::' is reserved. "prefix" and "suffix" use it to store - # the global message prefix / suffix. - # - prefix and suffix are applied per message. - # - header and trailer are per line. And should not generate multiple lines! -} - -# # ## ### ##### ######## ############# ##################### -## Ready - -package provide debug 1.0.6 -return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictn-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictn-0.1.2.tm deleted file mode 100644 index 2ed2b1ef..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictn-0.1.2.tm +++ /dev/null @@ -1,366 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# 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) 2023 -# -# @@ Meta Begin -# Application dictn 0.1.2 -# Meta platform tcl -# Meta license -# @@ Meta End - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -##e.g package require frobz - - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval dictn { - namespace export {[a-z]*} - namespace ensemble create -} - - -## ::dictn::append -#This can of course 'ruin' a nested dict if applied to the wrong element -# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: -# %set list {a b {c d}} -# %append list x -# a b {c d}x -# IOW - don't do that unless you really know that's what you want. -# -proc ::dictn::append {dictvar path {value {}}} { - if {[llength $path] == 1} { - uplevel 1 [list dict append $dictvar $path $value] - } else { - upvar 1 $dictvar dvar - - ::set str [dict get $dvar {*}$path] - append str $val - dict set dvar {*}$path $str - } -} - -proc ::dictn::create {args} { - ::set data {} - foreach {path val} $args { - dict set data {*}$path $val - } - return $data -} - -proc ::dictn::exists {dictval path} { - return [dict exists $dictval {*}$path] -} - -proc ::dictn::filter {dictval path filterType args} { - ::set sub [dict get $dictval {*}$path] - dict filter $sub $filterType {*}$args -} - -proc ::dictn::for {keyvalvars dictval path body} { - ::set sub [dict get $dictval {*}$path] - dict for $keyvalvars $sub $body -} - -proc ::dictn::get {dictval {path {}}} { - return [dict get $dictval {*}$path] -} - - -if {[info commands ::tcl::dict::getdef] ne ""} { - #tcl 9+ - proc ::dictn::getdef {dictval path default} { - return [dict getdef $dictval {*}$path $default] - } - - proc ::dictn::getwithdefault {dictval path default} { - return [dict getdef $dictval {*}$path $default] - } - - proc ::dictn::incr {dictvar path {increment {}} } { - if {$increment eq ""} { - ::set increment 1 - } - if {[llength $path] == 1} { - uplevel 1 [list dict incr $dictvar $path $increment] - } else { - upvar 1 $dictvar dvar - if {![::info exists dvar]} { - dict set dvar {*}$path $increment - } else { - ::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}] - dict set dvar {*}$path $newval - } - return $dvar - } - } -} else { - #tcl < 9 - proc ::dictn::getdef {dictval path default} { - if {[tcl::dict::exists $dictval {*}$path]} { - return [tcl::dict::get $dictval {*}$path] - } else { - return $default - } - } - proc ::dictn::getwithdefault {dictval path default} { - if {[tcl::dict::exists $dictval {*}$path]} { - return [tcl::dict::get $dictval {*}$path] - } else { - return $default - } - } - proc ::dictn::incr {dictvar path {increment {}} } { - if {$increment eq ""} { - ::set increment 1 - } - if {[llength $path] == 1} { - uplevel 1 [list dict incr $dictvar $path $increment] - } else { - upvar 1 $dictvar dvar - if {![::info exists dvar]} { - dict set dvar {*}$path $increment - } else { - if {![dict exists $dvar {*}$path]} { - ::set val 0 - } else { - ::set val [dict get $dvar {*}$path] - } - ::set newval [expr {$val + $increment}] - dict set dvar {*}$path $newval - } - return $dvar - } - } -} - -proc ::dictn::info {dictval {path {}}} { - if {![string length $path]} { - return [dict info $dictval] - } else { - ::set sub [dict get $dictval {*}$path] - return [dict info $sub] - } -} - -proc ::dictn::keys {dictval {path {}} {glob {}}} { - ::set sub [dict get $dictval {*}$path] - if {[string length $glob]} { - return [dict keys $sub $glob] - } else { - return [dict keys $sub] - } -} - -proc ::dictn::lappend {dictvar path args} { - if {[llength $path] == 1} { - uplevel 1 [list dict lappend $dictvar $path {*}$args] - } else { - upvar 1 $dictvar dvar - - ::set list [dict get $dvar {*}$path] - ::lappend list {*}$args - dict set dvar {*}$path $list - } -} - -proc ::dictn::merge {args} { - error "nested merge not yet supported" -} - -#dictn remove dictionaryValue ?path ...? -proc ::dictn::remove {dictval args} { - ::set basic [list] ;#buffer basic (1element path) removals to do in a single call. - - foreach path $args { - if {[llength $path] == 1} { - ::lappend basic $path - } else { - #extract,modify,replace - ::set subpath [lrange $path 0 end-1] - - ::set sub [dict get $dictval {*}$subpath] - ::set sub [dict remove $sub [lindex $path end]] - - dict set dictval {*}$subpath $sub - } - } - - if {[llength $basic]} { - return [dict remove $dictval {*}$basic] - } else { - return $dictval - } -} - - -proc ::dictn::replace {dictval args} { - ::set basic [list] ;#buffer basic (1element path) replacements to do in a single call. - - foreach {path val} $args { - if {[llength $path] == 1} { - ::lappend basic $path $val - } else { - #extract,modify,replace - ::set subpath [lrange $path 0 end-1] - - ::set sub [dict get $dictval {*}$subpath] - ::set sub [dict replace $sub [lindex $path end] $val] - - dict set dictval {*}$subpath $sub - } - } - - - if {[llength $basic]} { - return [dict replace $dictval {*}$basic] - } else { - return $dictval - } -} - - -proc ::dictn::set {dictvar path newval} { - upvar 1 $dictvar dvar - return [dict set dvar {*}$path $newval] -} - -proc ::dictn::size {dictval {path {}}} { - return [dict size [dict get $dictval {*}$path]] -} - -proc ::dictn::unset {dictvar path} { - upvar 1 $dictvar dvar - return [dict unset dvar {*}$path -} - -proc ::dictn::update {dictvar args} { - ::set body [lindex $args end] - ::set maplist [lrange $args 0 end-1] - - upvar 1 $dictvar dvar - foreach {path var} $maplist { - if {[dict exists $dvar {*}$path]} { - uplevel 1 [list set $var [dict get $dvar $path]] - } - } - - catch {uplevel 1 $body} result - - foreach {path var} $maplist { - if {[dict exists $dvar {*}$path]} { - upvar 1 $var $var - if {![::info exists $var]} { - uplevel 1 [list dict unset $dictvar {*}$path] - } else { - uplevel 1 [list dict set $dictvar {*}$path [::set $var]] - } - } - } - return $result -} - -#an experiment. -proc ::dictn::Applyupdate {dictvar args} { - ::set body [lindex $args end] - ::set maplist [lrange $args 0 end-1] - - upvar 1 $dictvar dvar - - ::set headscript "" - ::set i 0 - foreach {path var} $maplist { - if {[dict exists $dvar {*}$path]} { - #uplevel 1 [list set $var [dict get $dvar $path]] - ::lappend arglist $var - ::lappend vallist [dict get $dvar {*}$path] - ::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ] - ::append headscript \n - ::incr i - } - } - - ::set body $headscript\r\n$body - - puts stderr "BODY: $body" - - #set result [apply [list args $body] {*}$vallist] - catch {apply [list args $body] {*}$vallist} result - - foreach {path var} $maplist { - if {[dict exists $dvar {*}$path] && [::info exists $var]} { - dict set dvar {*}$path [::set $var] - } - } - return $result -} - -proc ::dictn::values {dictval {path {}} {glob {}}} { - ::set sub [dict get $dictval {*}$path] - if {[string length $glob]} { - return [dict values $sub $glob] - } else { - return [dict values $sub] - } -} - -# Standard form: -#'dictn with dictVariable path body' -# -# Extended form: -#'dictn with dictVariable path arrayVariable body' -# -proc ::dictn::with {dictvar path args} { - if {[llength $args] == 1} { - ::set body [lindex $args 0] - return [uplevel 1 [list dict with $dictvar {*}$path $body]] - } else { - upvar 1 $dictvar dvar - ::lassign $args arrayname body - - upvar 1 $arrayname arr - array set arr [dict get $dvar {*}$path] - ::set prevkeys [array names arr] - - catch {uplevel 1 $body} result - - - foreach k $prevkeys { - if {![::info exists arr($k)]} { - dict unset $dvar {*}$path $k - } - } - foreach k [array names arr] { - dict set $dvar {*}$path $k $arr($k) - } - - return $result - } -} - - - - - - - - - - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide dictn [namespace eval dictn { - variable version - ::set version 0.1.2 -}] -return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictutils-0.2.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictutils-0.2.1.tm deleted file mode 100644 index 12ca495b..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/dictutils-0.2.1.tm +++ /dev/null @@ -1,145 +0,0 @@ -# dictutils.tcl -- - # - # Various dictionary utilities. - # - # Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk). - # - # License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style). - # - - #2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" - - package require Tcl 8.6- - package provide dictutils 0.2.1 - - namespace eval dictutils { - namespace export equal apply capture witharray nlappend - namespace ensemble create - - # dictutils witharray dictVar arrayVar script -- - # - # Unpacks the elements of the dictionary in dictVar into the array - # variable arrayVar and then evaluates the script. If the script - # completes with an ok, return or continue status, then the result is copied - # back into the dictionary variable, otherwise it is discarded. A - # [break] can be used to explicitly abort the transaction. - # - proc witharray {dictVar arrayVar script} { - upvar 1 $dictVar dict $arrayVar array - array set array $dict - try { uplevel 1 $script - } on break {} { # Discard the result - } on continue result - on ok result { - set dict [array get array] ;# commit changes - return $result - } on return {result opts} { - set dict [array get array] ;# commit changes - dict incr opts -level ;# remove this proc from level - return -options $opts $result - } - # All other cases will discard the changes and propagage - } - - # dictutils equal equalp d1 d2 -- - # - # Compare two dictionaries for equality. Two dictionaries are equal - # if they (a) have the same keys, (b) the corresponding values for - # each key in the two dictionaries are equal when compared using the - # equality predicate, equalp (passed as an argument). The equality - # predicate is invoked with the key and the two values from each - # dictionary as arguments. - # - proc equal {equalp d1 d2} { - if {[dict size $d1] != [dict size $d2]} { return 0 } - dict for {k v} $d1 { - if {![dict exists $d2 $k]} { return 0 } - if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 } - } - return 1 - } - - # apply dictVar lambdaExpr ?arg1 arg2 ...? -- - # - # A combination of *dict with* and *apply*, this procedure creates a - # new procedure scope populated with the values in the dictionary - # variable. It then applies the lambdaTerm (anonymous procedure) in - # this new scope. If the procedure completes normally, then any - # changes made to variables in the dictionary are reflected back to - # the dictionary variable, otherwise they are ignored. This provides - # a transaction-style semantics whereby atomic updates to a - # dictionary can be performed. This procedure can also be useful for - # implementing a variety of control constructs, such as mutable - # closures. - # - proc apply {dictVar lambdaExpr args} { - upvar 1 $dictVar dict - set env $dict ;# copy - lassign $lambdaExpr params body ns - if {$ns eq ""} { set ns "::" } - set body [format { - upvar 1 env __env__ - dict with __env__ %s - } [list $body]] - set lambdaExpr [list $params $body $ns] - set rc [catch { ::apply $lambdaExpr {*}$args } ret opts] - if {$rc == 0} { - # Copy back any updates - set dict $env - } - return -options $opts $ret - } - - # capture ?level? ?exclude? ?include? -- - # - # Captures a snapshot of the current (scalar) variable bindings at - # $level on the stack into a dictionary environment. This dictionary - # can later be used with *dictutils apply* to partially restore the - # scope, creating a first approximation of closures. The *level* - # argument should be of the forms accepted by *uplevel* and - # designates which level to capture. It defaults to 1 as in uplevel. - # The *exclude* argument specifies an optional list of literal - # variable names to avoid when performing the capture. No variables - # matching any item in this list will be captured. The *include* - # argument can be used to specify a list of glob patterns of - # variables to capture. Only variables matching one of these - # patterns are captured. The default is a single pattern "*", for - # capturing all visible variables (as determined by *info vars*). - # - proc capture {{level 1} {exclude {}} {include {*}}} { - if {[string is integer $level]} { incr level } - set env [dict create] - foreach pattern $include { - foreach name [uplevel $level [list info vars $pattern]] { - if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue } - upvar $level $name value - catch { dict set env $name $value } ;# no arrays - } - } - return $env - } - - # nlappend dictVar keyList ?value ...? - # - # Append zero or more elements to the list value stored in the given - # dictionary at the path of keys specified in $keyList. If $keyList - # specifies a non-existent path of keys, nlappend will behave as if - # the path mapped to an empty list. - # - proc nlappend {dictvar keylist args} { - upvar 1 $dictvar dict - if {[info exists dict] && [dict exists $dict {*}$keylist]} { - set list [dict get $dict {*}$keylist] - } - lappend list {*}$args - dict set dict {*}$keylist $list - } - - # invoke cmd args... -- - # - # Helper procedure to invoke a callback command with arguments at - # the global scope. The helper ensures that proper quotation is - # used. The command is expected to be a list, e.g. {string equal}. - # - proc invoke {cmd args} { uplevel #0 $cmd $args } - - } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm deleted file mode 100644 index 970e47da..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.1.tm +++ /dev/null @@ -1,568 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# 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) 2024 -# -# @@ Meta Begin -# Application fauxlink 0.1.1 -# Meta platform tcl -# Meta license MIT -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin fauxlink_module_fauxlink 0 0.1.1] -#[copyright "2024"] -#[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}] -#[moddesc {.fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] -#[require fauxlink] -#[keywords symlink faux fake shortcut toml] -#[description] -#[para] A cross platform shortcut/symlink alternative. -#[para] Unapologetically ugly - but practical in certain circumstances. -#[para] A solution is required for application-driven filesystem links that survives cross platform moves as well as -#[para] archiving and packaging systems. -#[para] The target is specified in a minimally-encoded form in the filename itself - but still human readable. -#[para] format of name #.fauxlink -#[para] where can be empty - then the effective nominal name is the tail of the -#[para] The file extension must be .fauxlink or .fxlnk -#[para] The + symbol substitutes for forward-slashes. -#[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) -#[para] We deliberately treat higher % sequences literally. -#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [lb]heart[rb]) can remain literal for linking to urls. -#[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 -#[para] e.g a link to a file file#A.txt in parent dir could be: -#[para] file%23A.txt#..+file%23A.txt.fauxlink -#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fauxlink -#[para] The can be unrelated to the actual target -#[para] e.g datafile.dat#..+file%23A.txt.fauxlink -#[para] This system has no filesystem support - and must be completely application driven. -#[para] This can be useful for example in application test packages which may be tarred or zipped and moved cross platform. -#[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined -#[para] Extensions to behaviour should be added in the file as text data in Toml format, -#[para] with custom data being under a single application-chosen table name -#[para] The toplevel Toml table [lb]fauxlink[rb] is reserved for core extensions to this system. -#[para] Aside from the 2 used for delimiting (+ #) -#[para] certain characters which might normally be allowed in filesystems are required to be encoded -#[para] e.g space and tab are required to be %20 %09 -#[para] Others that require encoding are: * ? \ / | : ; " < > -#[para] The nul character in raw form, when detected, is always mapped away to the empty string - as very few filesystems support it. -#[para] Control characters and other punctuation is optional to encode. -#[para] Generally utf-8 should be used where possible and unicode characters can often be left unencoded on modern systems. -#[para] Where encoding of unicode is desired in the nominalname,encodedtarget,tag or comment portions it can be specified as %UXXXXXXXX -#[para] There must be between 1 and 8 X digits following the %U. Interpretation of chars following %U stops at the first non-hex character. -#[para] This means %Utest would not get any translation as there were no hex digits so it would come out as %Utest -# -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#https://learn.microsoft.com/en-us/troubleshoot/windows-client/networking/url-encoding-unc-paths-not-url-decoded -# ie "//server/c/Program files" works but "//server/c/Program%20Files" is now treated by windows as a literal path with %20 in it. -#Using fauxlink - a link would be: -# "my-program-files#++server+c+Program%20Files.fauxlink" -#If we needed the old-style literal %20 it would become -# "my-program-files#++server+c+Program%2520Files.fauxlink" -# -# The file:// scheme on windows supposedly *does* decode %xx (for use in a browser) -# e.g -# pfiles#file%3a++++localhost+c+Program%2520files -# The browser will work with literal spaces too though - so it could just as well be: -# pfiles#file%3a++++localhost+c+Program%20files -#windows may default to using explorer.exe instead of a browser for file:// urls though -#and explorer doesn't want the literal %20. It probably depends what API the file:// url is to be passed to? -#in a .url shortcut either literal space or %20 will work ie %xx values are decoded - - - -#*** !doctools -#[section Overview] -#[para] overview of fauxlink -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by fauxlink -#[list_begin itemized] - -package require Tcl 8.6- -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval fauxlink::class { - #*** !doctools - #[subsection {Namespace fauxlink::class}] - #[para] class definitions - if {[info commands [namespace current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval fauxlink { - namespace export {[a-z]*}; # Convention: export all lowercase - - #todo - enforce utf-8 - - #literal unicode chars supported by modern filesystems - leave as is - REVIEW - - - variable encode_map - variable decode_map - #most filesystems don't allow NULL - map to empty string - - #Make sure % is not in encode_map - set encode_map [dict create\ - \x00 ""\ - { } %20\ - \t %09\ - + %2B\ - # %23\ - * %2A\ - ? %3F\ - \\ %5C\ - / %2F\ - | %7C\ - : %3A\ - {;} %3B\ - {"} %22\ - < %3C\ - > %3E\ - ] - #above have some overlap with ctrl codes below. - #no big deal as it's a dict - - #must_encode - # + # * ? \ / | : ; " < > \t - # also NUL to empty string - - # also ctrl chars 01 to 1F (1..31) - for {set i 1} {$i < 32} {incr i} { - set ch [format %c $i] - set enc "%[format %02X $i]" - set enc_lower [string tolower $enc] - dict set encode_map $ch $enc - dict set decode_map $enc $ch - dict set decode_map $enc_lower $ch - } - - variable must_encode - set must_encode [dict keys $encode_map] - - - #if they are in - - #decode map doesn't include - # %00 (nul) - # %2F "/" - # %2f "/" - # %7f (del) - #we exlude the forward slash because we already have + for that - and multiple ways to specify it obscure intention. - # - set decode_map [dict merge $decode_map [dict create\ - %09 \t\ - %20 { }\ - %21 "!"\ - %22 {"}\ - %23 "#"\ - %24 "$"\ - %25 "%"\ - %26 "&"\ - %27 "'"\ - %28 "("\ - %29 ")"\ - %2A "*"\ - %2a "*"\ - %2B "+"\ - %2b "+"\ - %2C ","\ - %2c ","\ - %2D "-"\ - %2d "-"\ - %2E "."\ - %2e "."\ - %3A ":"\ - %3a ":"\ - %3B {;}\ - %3b {;}\ - %3D "="\ - %3C "<"\ - %3c "<"\ - %3d "="\ - %3E ">"\ - %3e ">"\ - %3F "?"\ - %3f "?"\ - %40 "@"\ - %5B "\["\ - %5b "\["\ - %5C "\\"\ - %5c "\\"\ - %5D "\]"\ - %5d "\]"\ - %5E "^"\ - %5e "^"\ - %60 "`"\ - %7B "{"\ - %7b "{"\ - %7C "|"\ - %7c "|"\ - %7D "}"\ - %7d "}"\ - %7E "~"\ - %7e "~"\ - ]] - #Don't go above 7f - #if we want to specify p - - - #*** !doctools - #[subsection {Namespace fauxlink}] - #[para] Core API functions for fauxlink - #[list_begin definitions] - proc Segment_mustencode_check {str} { - variable decode_map - variable encode_map ;#must_encode - set idx 0 - set err "" - foreach ch [split $str ""] { - if {[dict exists $encode_map $ch]} { - set enc [dict get $encode_map $ch] - if {[dict exists $decode_map $enc]} { - append err " char $idx should be encoded as $enc" \n - } else { - append err " no %xx encoding available. Use %UXX if really required" \n - } - } - incr idx - } - return $err ;#empty string if ok - } - - proc resolve {link} { - variable decode_map - variable encode_map - variable must_encode - set ftail [file tail $link] - set extension_name [string range [file extension $ftail] 1 end] - if {$extension_name ni [list fxlnk fauxlink]} { - set is_fauxlink 0 - #we'll process anyway - but return the result wrapped - #This should allow deliberate erroring for the calling dict user if the extension difference is inadvertent - #(e.g blindly processing all files in a folder that is normally only .fauxlink files - but then something added that happens - # to have # characters in it) - #It also means if someone really wants to use the fauxlink semantics on a different file type - # - they can - but just have to access the results differently and take that (minor) risk. - #error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" - set err_extra "\nnonstandard extension '$extension_name' for fauxlink. (expected .fxlnk or .fauxlink) Check that the call to fauxlink::resolve was deliberate" - } else { - set is_fauxlink 1 - set err_extra "" - } - set linkspec [file rootname $ftail] - # - any # or + within the target path or name should have been uri encoded as %23 and %2b - if {[tcl::string::first # $linkspec] < 0} { - set err "fauxlink::resolve '$link'. Link must contain a # (usually at start if name matches target)" - append err $err_extra - error $err - } - #The 1st 2 parts of split on # are name and target file/dir - #If there are only 3 parts the 3rd part is a comment and there are no 'tags' - #if there are 4 parts - the 3rd part is a tagset where each tag begins with @ - #and each subsequent part is a comment. Empty comments are stripped from the comments list - #A tagset can be empty - but if it's not empty it must contain at least one @ and must start with @ - #e.g name.txt#path#@tag1@tag2#test###.fauxlink - #has a name, a target, 2 tags and one comment - - #check namespec already has required chars encoded - set segments [split $linkspec #] - lassign $segments namespec targetspec - #puts stderr "-->namespec $namespec" - set nametest [tcl::string::map $encode_map $namespec] - #puts stderr "-->nametest $nametest" - #nothing should be changed - if there are unencoded chars that must be encoded it is an error - if {[tcl::string::length $nametest] ne [tcl::string::length $namespec]} { - set err "fauxlink::resolve '$link' invalid chars in name part (section prior to first #)" - append err [Segment_mustencode_check $namespec] - append err $err_extra - error $err - } - #see comments below regarding 2 rounds and ordering. - set name [decode_unicode_escapes $namespec] - set name [tcl::string::map $decode_map $name] - #puts stderr "-->name: $name" - - set targetsegment [split $targetspec +] - #check each + delimited part of targetspec already has required chars encoded - set pp 0 ;#pathpart index - set targetpath_parts [list] - foreach pathpart $targetsegment { - set targettest [tcl::string::map $encode_map $pathpart] - if {[tcl::string::length $targettest] ne [tcl::string::length $pathpart]} { - set err "fauxlink::resolve '$link' invalid chars in targetpath (section following first #)" - append err [Segment_mustencode_check $pathpart] - append err $err_extra - error $err - } - #2 rounds of substitution is possibly asking for trouble.. - #We allow anything in the resultant segments anyway (as %UXXXX... allows all) - #so it's not so much about what can be encoded, - # - but it makes it harder to reason about for users - # In particular - if we map %XX first it makes %25 -> % substitution tricky - # if the user requires a literal %UXXX - they can't do %25UXXX - # the double sub would make it %UXXX -> somechar anyway. - #we do unicode first - as a 2nd round of %XX substitutions is unlikely to interfere. - #There is still the opportunity to use things like %U00000025 followed by hex-chars - # and get some minor surprises, but using %U on ascii is unlikely to be done accidentally - REVIEW - set pathpart [decode_unicode_escapes $pathpart] - set pathpart [tcl::string::map $decode_map $pathpart] - lappend targetpath_parts $pathpart - - incr pp - } - set targetpath [join $targetpath_parts /] - if {$name eq ""} { - set name [lindex $targetpath_parts end] - } - #we do the same encoding checks on tags and comments to increase chances of portability - set tags [list] - set comments [list] - switch -- [llength $segments] { - 2 { - #no tags or comments - } - 3 { - #only 3 sections - last is comment - even if looks like tags - #to make the 3rd part a tagset, an extra # would be needed - set comments [list [lindex $segments 2]] - } - default { - set tagset [lindex $segments 2] - if {$tagset eq ""} { - #ok - no tags - } else { - if {[string first @ $tagset] != 0} { - set err "fauxlink::resolve '$link' invalid tagset in 3rd #-delimited segment" - append err \n " - must begin with @" - append err $err_extra - error $err - } else { - set tagset [string range $tagset 1 end] - set rawtags [split $tagset @] - set tags [list] - foreach t $rawtags { - if {$t eq ""} { - lappend tags "" - } else { - set tagtest [tcl::string::map $encode_map $t] - if {[tcl::string::length $tagtest] ne [tcl::string::length $t]} { - set err "fauxlink::resolve '$link' invalid chars in tag [llength $tags]" - append err [Segment_mustencode_check $t] - append err $err_extra - error $err - } - lappend tags [tcl::string::map $decode_map [decode_unicode_escapes $t]] - } - } - } - } - set rawcomments [lrange $segments 3 end] - #set comments [lsearch -all -inline -not $comments ""] - set comments [list] - foreach c $rawcomments { - if {$c eq ""} {continue} - set commenttest [tcl::string::map $encode_map $c] - if {[tcl::string::length $commenttest] ne [tcl::string::length $c]} { - set err "fauxlink::resolve '$link' invalid chars in comment [llength $comments]" - append err [Segment_mustencode_check $c] - append err $err_extra - error $err - } - lappend comments [tcl::string::map $decode_map [decode_unicode_escapes $c]] - } - } - } - - set data [dict create name $name targetpath $targetpath tags $tags comments $comments fauxlinkextension $extension_name] - if {$is_fauxlink} { - #standard .fxlnk or .fauxlink - return $data - } else { - #custom extension - or called in error on wrong type of file but happened to parse. - #see comments at top regarding is_fauxlink - #make sure no keys in common at top level. - return [dict create\ - linktype $extension_name\ - note "nonstandard extension returning nonstandard dict with result in data key"\ - data $data\ - ] - } - } - variable map - - #default exclusion of / (%U2f and equivs) - #this would allow obfuscation of intention - when we have + for that anyway - proc decode_unicode_escapes {str {exclusions {/ \n \r \x00}}} { - variable map - set ucstart [string first %U $str 0] - if {$ucstart < 0} { - return $str - } - set max 8 - set map [list] - set strend [expr {[string length $str]-1}] - while {$ucstart >= 0} { - set s $ucstart - set i [expr {$s +2}] ;#skip the %U - set hex "" - while {[tcl::string::length $hex] < 8 && $i <= $strend} { - set in [string index $str $i] - if {[tcl::string::is xdigit -strict $in]} { - append hex $in - } else { - break - } - incr i - } - if {$hex ne ""} { - incr i -1 - lappend map $s $i $hex - } - set ucstart [tcl::string::first %U $str $i] - } - set out "" - set lastidx -1 - set e 0 - foreach {s e hex} $map { - append out [string range $str $lastidx+1 $s-1] - set sub [format %c 0x$hex] - if {$sub in $exclusions} { - append out %U$hex ;#put it back - } else { - append out $sub - } - set lastidx $e - } - if {$e < [tcl::string::length $str]-1} { - append out [string range $str $e+1 end] - } - return $out - } - proc link_as {name target} { - - } - - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace fauxlink ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval fauxlink::lib { - namespace export {[a-z]*}; # Convention: export all lowercase - namespace path [namespace parent] - #*** !doctools - #[subsection {Namespace fauxlink::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 fauxlink::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -namespace eval fauxlink::system { - #*** !doctools - #[subsection {Namespace fauxlink::system}] - #[para] Internal functions that are not part of the API - - - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide fauxlink [namespace eval fauxlink { - variable pkg fauxlink - variable version - set version 0.1.1 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/flagfilter-0.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/flagfilter-0.3.tm deleted file mode 100644 index 00f58e82..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/flagfilter-0.3.tm +++ /dev/null @@ -1,2717 +0,0 @@ -#package provide flagfilter [namespace eval flagfilter {list [variable version 0.2.3]$version}] -#package provide [set ::pkg flagfilter-0.2.3] [namespace eval [lindex [split $pkg -] 0] {list [variable version [lindex [split $pkg -] 1][set ::pkg {}]]$version}] -# -#package provide [lindex [set pkg {flagfilter 0.2.3}] 0] [namespace eval [lindex $pkg 0] {list [variable version [lindex $pkg 1][set pkg {}]]$version}] -package provide [lassign {flagfilter 0.3} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}] - -#Note: this is ugly.. particularly when trying to classify flags that are not fully specified i.e raw passthrough. -# - we can't know if a flag -x --x etc is expecting a parameter or not. -#0.2.2 2023-03 JN - added %match% placeholder support. Can be added to the dispatch command to tell it what command was actually matched. e.g tell xxx.tcl script that it was xxx.tcl when we matched on *.tcl - - -namespace eval flagfilter { - package require oolib ;# make 'oolib::collection new' available - - proc do_errorx {msg {code 1}} { - if {$::tcl_interactive} { - error $msg - } else { - puts stderr "|>err $msg" - exit $code - } - } - - proc do_error {msg {then error}} { - set levels [list debug info notice warn error critical alert emergency] - #note we exit or error out even if debug selected - as every do_error call is meant to interrupt code processing at the site of call - #this is not just a 'logging' call even though it has syslog-like level descriptors - lassign $then type code - if {$code eq ""} { - set code 1 - } - set type [string tolower $type] - if {$type in [concat $levels exit]} { - puts -nonewline stderr "|$type> $msg\n" - } else { - puts -nonewline stderr "|flagfilter> unable to interpret 2nd argument to do_error: '$then' should be one of '$levels' or 'exit '\n" - } - flush stderr - if {$::tcl_interactive} { - #may not always be desirable - but assumed to be more useful not to exit despite request, to aid in debugging - if {[string tolower $type] eq "exit"} { - puts -nonewline stderr " (exit suppressed due to tcl_interactive - raising error instead)\n" - if {![string is digit -strict $code]} { - puts -nonewline stderr "|flagfilter> unable to interpret 2nd argument to do_error: '$then' should be: 'exit '\n" - } - } - flush stderr - return -code error $msg - } else { - if {$type ne "exit"} { - return -code error $msg - } else { - if {[string is digit -strict $code]} { - exit $code - } else { - puts -nonewline stderr "|flagfilter> unable to interpret 2nd argument to do_error: '$then' should be 'error' or 'exit '\n" - flush stderr - return -code error $msg - } - } - } - } - proc scriptdir {} { - set possibly_linked_script [file dirname [file normalize [file join [info script] ...]]] - if {[file isdirectory $possibly_linked_script]} { - return $possibly_linked_script - } else { - return [file dirname $possibly_linked_script] - } - } - -} - -package require overtype - - -namespace eval flagfilter { - namespace export get_one_flag_value - #review. Tcl can handle args like: {-a -val1 -b -val2} as long as they pair up. - #this will ignore flag-like values if they follow a -flag - # positional values that happen to start with - can still cause issues - #get_flagged_only can return an unpaired list if there are solos, or if it finds no value for the last flaglike element - # e.g from input {something -x -y -z} we will get {-x -y -z} - # - # - - #flagfilter::get_flagged_only may not always get things right when looking at a values list with command processors - #Even if all solos from commands are supplied in solodict - a flag might be solo only in the context of a particualar commandset - #The proper way to get flagged values from an arglist is to run the full parser. - #This then should be restricted to use for a specific subset of args where the supplied solodict is known to apply - proc get_flagged_only {arglist solodict} { - #solodict - solo flags with defaults - set solo_accumulator [dict create] ;#if multiple instances of solo flag found - append defaults to the value to form a list as long as the number of occurrences - #puts ">>>get_flagged_only input $arglist solodict:'$solodict'" - set result [list] - set last_was_flag 0 - set result [list] - set a_idx 0 - set end_of_options 0 - foreach a $arglist { - if {$a eq "--"} { - break - } - if {[dict exists $solodict $a]} { - set last_was_flag 0 - if {[dict exists $solo_accumulator $a]} { - set soloval [concat [dict get $solo_accumulator $a] [dict get $solodict $a]] - } else { - set soloval [dict get $solodict $a] - } - dict set solo_accumulator $a $soloval - #we need to keep order of first appearance - set idx [lsearch $result $a] - if {$idx < 0} { - lappend result $a $soloval - } else { - lset result $idx+1 $soloval - } - } else { - if {!$last_was_flag} { - if {$a eq "--"} { - - } else { - if {[lindex $arglist $a_idx-1] eq "--"} { - #end of options processing - none of the remaining are considered flags/options no matter what they look like - set last_was_flag 0 - break - } else { - if {[string match -* $a]} { - set last_was_flag 1 - lappend result $a ;#flag - } else { - #last wasnt, this isn't - don't output - set last_was_flag 0 - } - } - } - } else { - #we only look for single leading - in the value if last wasn't a flag - but we give -- and soloflags special treatment. - if {$a eq "--"} { - #last was flag - set last_was_flag 0 - } else { - lappend result $a ;#value - set last_was_flag 0 - } - } - } - incr a_idx - } - if {([llength $result] % 2) != 0} { - set last [lindex $result end] - if {[string match -* $last] && ($last ni [dict keys $solodict])} { - lappend result 1 - } - } - #puts ">>>get_flagged_only returning $result" - return $result - } - - - ## get_one_paired_flag_value - #best called with 'catch' unless flag known to be in arglist - #raises an error if no position available after the flag to retrieve value - #raises an error if flag not like -something - #raises an error if flag not found in list - proc get_one_paired_flag_value {arglist flag} { - if {![regexp -- {-{1}[^-]+|-{2}[^-]+} $flag]} { - #regexp excludes plain - and -- - #if {![string match -* $flag]} {} - error "get_one_flag_value flag $flag does not look like a flag. Should be something like -$flag or --$flag" - } - set cindex [lsearch $arglist $flag] - if {$cindex >= 0} { - set valueindex [expr {$cindex + 1}] - if {$valueindex < [llength $arglist]} { - #puts stderr "++++++++++++++++++ get_one_flag_value flag '$flag' returning [lindex $arglist $valueindex]" - return [lindex $arglist $valueindex] - } else { - error "flagfilter::get_one_paired_flag_value no value corresponding to flag $flag (found flag, but reached end of list)" - } - } else { - error "flagfilter::get_one_paired_flag_value $flag not found in arglist: '$arglist'" - } - } -} - -namespace eval flagfilter::obj { - -} - - -namespace eval flagfilter { - variable run_counter 0 ;#Used by get_new_runid to form an id to represent run of main check_flags function. - #used as a basis for some object-instance names etc - proc get_new_runid {} { - variable run_counter - if {[catch {package require Thread}]} { - set tid 0 - } else { - set tid [thread::id] - } - return "ff-[pid]-${tid}-[incr run_counter]" - } - - namespace export check_flags - proc do_debug {lvl debugconfig msg} { - if {$lvl <= [dict get $debugconfig -debugargs]} { - foreach ln [split $msg \n] { - puts -nonewline stderr "|[dict get $debugconfig -source]> $ln\n" - flush stderr - } - } - } - - #---------------------------------------------------------------------- - # DO NOT RELY ON tcl::unsupported - it's named that for a reason and is not meant to be parsed - #wiki.tcl-lang.org/page/dict+tips+and+tricks - proc isdict {v} { - if {[string match "value is a list *" [::tcl::unsupported::representation $v]]} { - return [expr {!([llength $v] % 2)}] - } else { - return [string match "value is a dict *" [::tcl::unsupported::representation $v]] - } - } - - proc dict_format {dict} { - dictformat_rec $dict "" " " - } - proc dictformat_rec {dict indent indentstring} { - # unpack this dimension - set is_empty 1 - dict for {key value} $dict { - set is_empty 0 - if {[isdict $value]} { - append result "$indent[list $key]\n$indent\{\n" - append result "[dictformat_rec $value "$indentstring$indent" $indentstring]\n" - append result "$indent\}\n" - } else { - append result "$indent[list $key] [list $value]\n" - } - } - if {$is_empty} { - #experimental.. - append result "$indent\n" - #append result "" - } - return $result - } - #-------------------------------------------------------------------------- - - #solo 'category' includes longopts with value - #solo flags include the general list of -soloflags, and those specific to the current -commandprocessors spec (mashopts and singleopts) - proc is_this_flag_solo {f solos objp} { - if {![string match -* $f]} { - #not even flaglike - return 0 - } - - - if {$f in $solos} { - #review! - global -soloflags shouldn't override the requirements of a commandprocessor! - #but.. each commandprocessor needs to understand global solos occuring before our match so that we classify correctly.. - #todo - this may need to reference v_map and current position in scanlist to do properly - return 1 - } - if {$f eq "-"} { - #unless the caller declared it as a solo - treat this as a non flag element. (likely use is as a command match) - return 0 - } - if {$f eq "--"} { - #this is it's own type endofoptions - return 0 - } - - set p_opts [$objp get_combined_opts] - - set mashopts [dict get $p_opts mashopts] - set singleopts [dict get $p_opts singleopts] - set pairopts [dict get $p_opts pairopts] - set longopts [dict get $p_opts longopts] - - if {$f in $singleopts} { - return 1 - } - - #"any" keywords used by processors to consume anything - where we're not too worried about classifying a flagvalue vs an operand - #examine these last so that an explicit configuration of flags as pairopts,mashopts etc can still be classified correctly - if {"any" in $singleopts} { - return 1 - } - if {[string first "=" $f] >=1} { - if {"any" in $longopts} { - return 1 - } - #todo foreach longopt - split on = and search - } - - #Flag could still be part of a solo if it is in mashopts *and* has a value following it as part of the mash - but if it's a pairopt, but not mashable - we can rule it out now - if {($f in $pairopts) && ($f ni $mashopts)} { - return 0 - } - #todo - suport mashes where one of the mashed flags takes an arg - review: only valid if it's last in the mash? - #(presumably so - unless we there was some other value delimiter such as isnumeric or capitalised flags vs lowercase values - but that seems a step too far - would require some sort of mashspec/mash-strategy config) - #last part of mash may actually be the value too. which complicates things - #linux ls seems to do this for example: - # ls -w 0 - # ls -lw 0 - # ls -lw0 - # also man.. e.g - # man -Tdvi - # man -Hlynx - # man -H - # - note this last one. '-H lynx' doesn't work - so it's a mashable opt that can take a value, but is not in pairopts! (-H with no value uses env value for browser) - # see also comments in is_this_flag_mash - # - - set flagletters [split [string range $f 1 end] ""] - set posn 1 - set is_solo 1 ;#default assumption to disprove - #trailing letters may legitimately not be in mashopts if they are part of a mashed value - #we can return 0 if we hit a non-mash flag first.. but at each mashflag we need to test if we can classify as definitely solo or not, or else keep processing - foreach l $flagletters { - if {"-$l" ni $mashopts} { - #presumably an ordinary flag not-known to us - return 0 - } else { - if {"-$l" in $pairopts} { - if {$posn == [llength $flagletters]} { - #in pairopts and mash - but no value for it in the mash - thefore not a solo - return 0 - } else { - #entire tail is the value - this letter is effectively solo - return 1 - } - } elseif {"-$l" in $singleopts} { - #not allowed to take a value - keep processing letters - } else { - #can take a value! but not if at very end of mash. Either way This is a solo - return 1 - } - } - } - return $is_solo - } - #todo? support global (non-processor specific) mash list? -mashflags ? - proc is_this_flag_mash {f objp} { - if {![regexp -- {-{1}[^-]+|-{2}[^-]+} $f]} { - #not even flaglike - return 0 - } - set optinfo [$objp get_combined_opts];#also applies to tail_processor - *usually* empty values for mashopts etc - - #we look at singleopts because even if the flag is in mashopts - when it is alone we don't classify it as a mash - set singleopts pdict get $optinfo singleopts] - if {$f in $singleopts} { - return 0 - } - - set pairopts [dict get $optinfo pairopts] - if {$f in [dict keys $pairopts]} { - #here, the entire arg (f) we are testing is in pairopts - it could still however appear as part of a mash, with or without a trailing value, and with or without other flags before it in the mash (but if neither prefixed,nor tailed then obviously not a mash) - return 0 - } - set mashopts [dict get $optinfo mashopts] - set flagletters [split [string range $f 1 end] ""] - set is_mash 1 ;#to disprove - all letters must be in mashopts to consider it a mash.. unless trailing one also takes a value - # .. in which case value could be at the tail of the mash.. or be the next arg in the list - # We will take absense from singleopts and pairopts to indicate the mashflag *optionally* takes a value - # (ie such a mashopt is a solo that can take a value only as a mashtail) - # presence in pairopts indicates a mashflag must have a value - # presense in singleopts indicates mashflag takes no value ever. - # mashopt cannot be in both singleopts and pairopts. (NAND) - foreach l $flagletters { - if {-$l in $pairopts} { - if {"-$l" in $mashopts} { - #need to consider any remainder in the mash as this value .. if no remainder - then this is a mash, but not 'solo' because this flag needs to consume the following arg. - # We are only concerned with mashness here so just stop processing mash elements when we hit the first one that is a pairopt - break - } else { - #we require the pairopt to explicitly be listed in mashopts as well as pairopts if it is to be allowed to be part of a mash - set is_mash 0 - } - } elseif {"-$l" in $singleopts} { - #singleopt & mashopt - cannot take a value, mashed or otherwise - if {"-$l" ni $mashopts} { - set is_mash 0 - } - } else { - if {"-$l" ni $mashopts} { - set is_mash 0 - } else { - #present only in mashopts - can take a value, but only immediately following in the mash - break - } - } - } - return $is_mash - } - proc is_this_flag_for_me {f objp cf_args} { - set processorname [$objp name] - set optinfo [$objp get_combined_opts] ;#also applies to tail_processor - *usually* empty values for mashopts etc - - if {$processorname in [list "tail_processor"]} { - return 1 - } - if {$processorname in [list "global"]} { - #todo - mashflags for global? - set defaults [dict get $cf_args -defaults] - set extras [dict get $cf_args -extras] - set soloflags [dict get $cf_args -soloflags] - if {$f in [concat $extras $soloflags [dict keys $defaults]]} { - return 1 - } - } - - set singleopts [dict get $optinfo singleopts] - if {"any" in [string tolower $singleopts]} { - #review semantics of 'all' here. does it mean any -xxx.. will match, or only if also in global -soloflags? - return 1 - } - set pairopts [dict get $optinfo pairopts] - set allopts [concat $singleopts [dict keys $pairopts]] - if {$f in $allopts} { - return 1 - } - - #process mashopts last - set mashopts [dict get $optinfo mashopts] - if {"any" in [string tolower $mashopts]} { - #if 'all' in mashopts - it can eat anything - review - is this even useful? - return 1 - } else { - set flagletters [split [string range $f 1 end] ""] - set is_mash 1 ;#to disprove - all letters must be in mashopts to consider it a mash - foreach l $flagletters { - if {"-$l" ni $mashopts} { - set is_mash 0 - } - } - return $is_mash - } - - return 0 - } - - - - proc add_dispatch_raw {recordvar parentname v} { - upvar $recordvar drecord - if {[dict exists $drecord $parentname]} { - set dispatchinfo [dict get $drecord $parentname raw] - lappend dispatchinfo $v - dict set drecord $parentname raw $dispatchinfo - } - } - proc add_dispatch_argument {recordvar parentname k v} { - upvar $recordvar drecord - if {[dict exists $drecord $parentname]} { - set dispatchinfo [dict get $drecord $parentname arguments] - lappend dispatchinfo $k $v ;#e.g -opt 1 - dict set drecord $parentname arguments $dispatchinfo - } - } - proc lsearch-all-stride-2 {l search} { - set posns [lmap i [lsearch -all $l $search] {expr {($i % 2) == 0 ? $i : [list x]}}] - return [lsearch -all -inline -not $posns x] - } - proc update_dispatch_argument {recordvar parentname k v} { - upvar $recordvar drecord - if {[dict exists $drecord $parentname]} { - set dispatchinfo [dict get $drecord $parentname arguments] - #can't assume there aren't repeat values e.g -v -v - #dict set dispatchinfo $k $v - if {[package vcompare [info tclversion] 8.7a5] >= 0} { - set posns [lsearch -all -stride 2 $dispatchinfo $k] - } else { - set posns [lsearch-all-stride-2 $dispatchinfo $k] - } - set lastitem [lindex $posns end] - if {[string length $lastitem]} { - set val_idx [expr {$lastitem + 1}] - set dispatchinfo [lreplace $dispatchinfo[set dispatchinfo {}] $val_idx $val_idx $v] ;# inlineK - dict set drecord $parentname arguments $dispatchinfo - } else { - error "Unable to update dispatch argument $k with value $v in dispatch record for $parentname" - } - #dict set drecord $parentname $dispatchinfo - } - } - - #Note the difference between this and is_command_match. - #Lack of a 'match' element does not cause a commandspec to skip allocating an operand it encounters - #Note that this isn't a general test to be applied to the entire argument list. - # - an arg may get matched by an earlier processor making it unavailable to be allocated by another processor - # so this test only applies during the ordered examination of args - proc can_this_commandspec_allocate_this_arg {flag cspec cf_args} { - set cmdinfo [lindex $cspec 1] - if {$cmdinfo eq "tail_processor"} { - return 1 - } - if {$cmdinfo eq "global"} { - set defaults [dict get $cf_args -defaults] - set soloflags [dict get $cf_args -soloflags] - set extras [dict get $cf_args -extras] - if {$flag in [concat $soloflags $extras [dict keys $defaults]]} { - return 1 - } - } - if {![dict exists $cmdinfo match]} { - return 1 - } - set matchspeclist [dict get $cmdinfo match] - foreach matchspec $matchspeclist { - if {[regexp -- $matchspec $flag]} { - return 1 - } - } - #only block it if there was a match pattern specified but it didn't match - return 0 - } - #Note - returns false for a cspec that has no match specified. - #A command/subcommand with no match specification is allowed to allocate any value - so be careful with this - # - it should not be used to *stop* an arg being allocated if the processor has no 'match' specified, or if it is another type of processor like 'tail_handler'. - proc is_command_match {flag cspec} { - set pinfo [lindex $cspec 1] - if {[dict exists $pinfo match]} { - set matchspeclist [dict get $pinfo match] - foreach matchspec $matchspeclist { - if {[regexp -- $matchspec $flag]} { - return 1 - } - } - return 0 - } else { - return 0 - } - } - proc is_command_match_any {f commandprocessors} { - foreach comspec $commandprocessors { - lassign $comspec cmdname cmdinfo - if {[dict exists $cmdinfo match]} { - set matchlist [dict get $cmdinfo match] - foreach matchspec $matchlist { - if {[regexp -- $matchspec $f]} { - #actually a command - return true - } - } - } - } - return false - } - - #determine if f is potentially a flag that takes a parameter from the next argument. - #e.g --x=y (longopt) does not consume following arg but --something *might* - proc is_candidate_toplevel_param_flag {f solos commandprocessors} { - if {[is_command_match_any $f $commandprocessors]} { - return false - } - if {$f in $solos} { - return 0 - } - if {$f in {- --}} { - return 0 - } - #longopts (--x=blah) and alternative --x blah - #possibly also -x=blah - if {[string match -* $f]} { - if {[string first "=" $f]>1} { - return 0 - } - } - return [expr {[string match -* $f]}] - } - - - - - - - - - - - - - - - - - - - #review - should we be using control::assert here? - #It depends if this is intended to raise error at runtime - would using control::assert and disabling assertions cause problems? - #todo - show caller info - proc assert_equal {a b} { - if {![expr {$a eq $b}]} { - error "assert_equal $a $b" - } - } - - - - - - #{1 unallocated 2 unallocated 3 unallocated 4 unallocated 5 unallocated 6 unallocated} ;#initial v_map - #1 2 3 4 5 6 ;#original list posns example - # 2 6 ;#map_remaining example (scanlist) - #1 3 4 5 ;#map_allocated example - #{1 {cmd1 operand} 2 unallocated 3 {cmd2 operand} 4 {cmd2 flag} 5 {cmd2 flagvalue} 6 unallocated} ;#v_map updated example - oo::class create class_vmap { - variable o_map - variable o_remaining - variable o_allocated - variable o_values - variable o_codemap - variable o_flagcategory - constructor {values} { - set o_codemap [dict create \ - operand op \ - flagvalue fv \ - soloflag so \ - flag fl \ - unallocated un \ - endofoptions eo \ - ] - set o_flagcategory [list "flag" "flagvalue" "soloflag"] - set o_values $values - #set o_remaining [lsearch -all $values *] ;#create a list of indices e.g 0 1 2 3 4 5 6 - #lsearch -all * is fast for very small lists - but lseq wins from size around 30+ - if {[llength $values]} { - if {[llength $values] < 30} { - #common case is short lists - but we don't want to penalize large lists - set o_remaining [lsearch -all $values *] - } else { - #punk::lib::range wraps lseq if available - set o_remaining [punk::lib::range 0 [llength $values]-1] - } - } else { - set o_remaining [list] - } - set o_allocated [list] - set o_map [list] - foreach posn $o_remaining { - lappend o_map $posn unallocated - } - } - method load {values rem alloc map} { - set o_values $values - set o_remaining $rem - set o_allocated $alloc - set o_map $map - } - method copy_to {obj} { - $obj load $o_values $o_remaining $o_allocated $o_map - } - method update_map_from {obj} { - #very basic sanity check first - if {[llength $o_values] ne [llength [$obj get_values]]} { - error "[self class].update_map_from cannot update. length of values mismatch" - } - - set newmap [$obj get_map] - } - - method get_codemap {} { - return $o_codemap - } - method get_values {} { - return $o_values - } - method get_remaining {} { - return $o_remaining - } - method get_allocated {} { - return $o_allocated - } - method get_map {} { - return $o_map - } - method argnum_from_remaining_posn {scanlist_posn} { - set vidx [lindex $o_remaining $scanlist_posn] - if {![string is digit -strict $vidx]} { - return -code error "[self class].argnum_from_remaining_posn cannot determine argnum from scanlist position:$scanlist_posn using unallocated list:'$o_remaining'" - } - return $vidx - } - - method allocate {objp argnum type value} { - set processorname [$objp name] - if {$processorname eq "tail_processor"} { - set owner "unallocated" - } else { - set owner [$objp parentname] - } - if {$argnum > [llength $o_values]-1} { - return -code error "[self class].allocate cannot allocate argnum:$argnum. Only [llength $o_values] items in value list" - } - if {$argnum in $o_allocated} { - return -code error "[self class].allocate already allocated '$processorname' argnum:'$argnum' type:'$type' val:'$value' remaining:$o_remaining allocated:$o_allocated map:$o_map" - } - lappend o_allocated $argnum - set o_allocated [lsort -dictionary $o_allocated] - dict set o_map $argnum [list $owner $type $value] - set scanlist_posn [lsearch $o_remaining $argnum] - set o_remaining [lreplace $o_remaining[set o_remaining {}] $scanlist_posn $scanlist_posn] ;#inlineK - - - - } - - method get_list_unflagged_by_class {classmatch} { - set resultlist [list] - dict for {k vinfo} $o_map { - lassign $vinfo class type val - if {[string match $classmatch $class]} { - switch -- $type { - flag - flagvalue - soloflag {} - default { - lappend resultlist $val - } - } - } - } - return $resultlist - } - - method get_list_flagged_by_class {classmatch} { - set list_flagged [list] - dict for {k vinfo} $o_map { - lassign $vinfo class type val - if {[string match $classmatch $class]} { - switch -- $type { - flag - flagvalue - soloflag { - lappend list_flagged $val - } - } - } - } - return $list_flagged - } - - method get_merged_flagged_by_class {classmatch} { - variable flagcategory - set all_flagged [list] - set seenflag [dict create] ;#key = -flagname val=earliest vindex - dict for {k vinfo} $o_map { - lassign $vinfo class type val - if {[string match $classmatch $class]} { - set a [llength $all_flagged] ;#index into all_flagged list we are building - switch -- $type { - soloflag { - if {[dict exists $seenflag $val]} { - set seenindex [dict get $seenflag $val] - set seenindexplus [expr {$seenindex+1}] - set existingvals [lindex $all_flagged $seenindexplus] - lappend existingvals 1 ;#1 indicating presence - stored as list rather than a count. todo: consider global or per-solo options to support incrementing instead? - lset all_flagged $seenindexplus $existingvals - } else { - dict set seenflag $val $a - lappend all_flagged $val 1 - } - } - flag { - if {![dict exists $seenflag $val]} { - dict set seenflag $val $a - lappend all_flagged $val - } - #no need to do anything if already seen - flagvalue must be next, and it will work out where to go. - } - flagvalue { - set idxflagfor [expr {$k -1}] - set flagforinfo [dict get $o_map $idxflagfor] - lassign $flagforinfo ffclass fftype ffval - #jn "--" following a flag could result in us getting here accidentaly.. review - set seenindex [dict get $seenflag $ffval] - if {$seenindex == [expr {$a-1}]} { - #usual case - this is a flagvalue following the first instance of the flag - lappend all_flagged $val - } else { - #write the value back to the seenindex+1 - set seenindexplus [expr {$seenindex+1}] - set existingvals [lindex $all_flagged $seenindexplus] - lappend existingvals $val ;#we keep multiples as a list - lset all_flagged $seenindexplus $existingvals - } - } - } - } - } - return $all_flagged - } - method typedrange_class_type_from_arg {argclass argtype} { - #set o_flagcategory [list "flag" "flagvalue" "soloflag"] - if {$argclass eq "unallocated"} { - switch -- $argtype { - flag - flagvalue - soloflag { - return [list unallocated flagtype] - } - default { - if {![string length $argtype]} { - #should only happen if something wrong with the tail_processor - rather than error out, for now at least make it stand out in the . - set argtype UNKNOWN - } - return [list unallocated ${argtype}type] ;#e.g unallocated_operand, unallocated_endofoptions - } - } - } else { - return [list $argclass argtype] ;# e.g command something - } - } - - method get_ranges_from_classifications {classifications} { - #puts stderr "get_ranges_from_classifications $classifications" - #examine classifications and create a list of ranges - set ranges [list];# e.g [list {unallocated 0 4} {cmd1 5 7} {unallocated 8 8} {cmd2 9 9} {cmd3 10 10} {unallocated 11 15}] - set seen_commands [list] - dict for {posn arginfo} $classifications { - set is_new_cmd 0 - set is_sub_cmd 0 - set is_continuation 0 - set rangename [lindex $ranges end 0] - set alloc [lindex $arginfo 0] ;#e.g of form 0 {unallocated operand} 1 {lscmd operand} 2 {lscmd soloflag} 3 {lscmd.dir operand} 4 {unallocated flag} - set cmdname "" - if {$alloc ne "unallocated"} { - if {$alloc ni $seen_commands} { - if {![llength $seen_commands]} { - set cmdname $alloc - set is_new_cmd 1 - } else { - set tail [lindex $seen_commands end] - if {$tail eq "unallocated"} { - set cmdname $alloc - set is_new_cmd 1 - } else { - if {[string first . $alloc] >= 0} { - set prefixcheck [lindex [split $alloc .] 0] - if {![string equal -length [string length $prefixcheck] $prefixcheck $tail]} { - #this is not unallocated, not a subcommand of the previous seen ie new command - set cmdname $alloc - set is_new_cmd 1 - } else { - set cmdname $prefixcheck - set is_sub_cmd 1 - set is_continuation 1 - } - } else { - set cmdname $alloc - set is_new_cmd 1 - } - } - } - } else { - set cmdname $alloc - set is_continuation 1 - } - if {$is_continuation} { - lassign [lindex $ranges end] _cmd n a b - set ranges [lrange $ranges 0 end-1] - lappend ranges [list command $n $a [incr b]] - flagfilter::assert_equal $b $posn - } elseif {$is_new_cmd} { - lappend seen_commands $alloc - if {$rangename eq ""} { - lappend ranges [list command $cmdname $posn $posn] - } else { - lassign [lindex $ranges end] _cmd n a b - lappend ranges [list command $cmdname [incr b] $posn] - flagfilter::assert_equal $b $posn - } - } else { - error "coding error during dispatch" - } - } else { - if {$rangename eq ""} { - lappend ranges [list unallocated mixed 0 0] - } else { - lassign [lindex $ranges end] class n a b - if {$class eq "unallocated"} { - #continuation - extend - set ranges [lrange $ranges 0 end-1] - lappend ranges [list unallocated mixed $a [incr b]] - } else { - #change from allocated to unallocated - lappend ranges [list unallocated mixed [incr b] $posn] - flagfilter::assert_equal $b $posn - } - } - } - } - set rangesbytype [list] - foreach oldrange $ranges { - lassign $oldrange oldrangeclass oldrangetype A B ;#A,B for original range bounds, a,b for bounds of sub-ranges we are creating - set last_type "" - set newrangelist [list] - set inner_range [list 0 0] - if {$oldrangeclass ne "unallocated"} { - #pass through - user can split commands further themselves by referencing the classifications map where each arg position is listed - set last_type $oldrangeclass ;#note the deliberate slight misuse - we are using the 'class' here rather than the type as we aren't looking at types within a command range - lappend rangesbytype $oldrange - } else { - #puts stdout "???????????????????????????????????????????????A$A B$B examining old range:'$oldrange'" - for {set i $A} {$i <= $B} {incr i} { - lassign [lindex $rangesbytype end] last_class last_type a b ;#enough just to use the type without the class - set a_info [dict get $classifications $i] - lassign $a_info argclass argtype v - lassign [my typedrange_class_type_from_arg $argclass $argtype] newrangeclass newrangetype - if {$last_type eq ""} { - lappend rangesbytype [list "unallocated" $newrangetype 0 0] - } else { - if {$last_type eq $newrangetype} { - set rangesbytype [lrange $rangesbytype 0 end-1] - lappend rangesbytype [list $last_class $last_type $a $i] - } else { - lappend rangesbytype [list $newrangeclass $newrangetype $i $i] - } - } - } - } - } - - return [list -ranges $ranges -rangesbytype $rangesbytype] - } - - method grid {} { - set posns [dict keys $o_map] - set col1 [string repeat " " 15] - set col [string repeat " " 4] - set pline "[overtype::left $col1 {var indices}] " - foreach p $posns { - append pline [overtype::left $col $p] - } - set remline "[overtype::left $col1 {unallocated}] " - foreach vidx $posns { - if {$vidx ni $o_remaining} { - append remline [overtype::left $col "."] - } else { - set tp [lindex [dict get $o_map $vidx] 1] - #set tp [string map $o_codemap $tp] - if {[dict exists $o_codemap $tp]} { - set tp [dict get $o_codemap $tp] - } - append remline [overtype::left $col $tp] - } - } - set cmdlist [list] - dict for {vidx info} $o_map { - if {[lindex $info 0] ne "unallocated"} { - set c [lindex [split [lindex $info 0] .] 0] - if {$c ni $cmdlist} { - lappend cmdlist $c - } - } - } - set clinelist [list] - foreach c $cmdlist { - set cline "[overtype::left $col1 $c] " - dict for {vidx info} $o_map { - lassign $info class type v - if {($c eq $class) || [string equal -length [string length "$c."] "$c." $class]} { - #set tp [string map $o_codemap $type] - if {[dict exists $o_codemap $type]} { - set tp [dict get $o_codemap $type] - } - append cline [overtype::left $col $tp] - } else { - append cline [overtype::left $col "."] - } - } - lappend clinelist $cline - } - - - set aline "[overtype::left $col1 {allocated}] " - foreach vidx $posns { - if {$vidx ni $o_allocated} { - append aline [overtype::left $col "."] - } else { - set tp [lindex [dict get $o_map $vidx] 1] - #set tp [string map $o_codemap $tp] - if {[dict exists $o_codemap $tp]} { - set tp [dict get $o_codemap $tp] - } - append aline [overtype::left $col $tp] - } - } - - return "$pline\n$remline\n[join $clinelist \n]\n$aline\n" - } - - } - - - #!todo - check if -commandprocessors members will collide with existing -flags in values before moving them - #!todo - skip optional sub-flag value if the next arg following its parent is a flag i.e proper handling of -commandprocessors {cmd {cmd sub "default}} when only cmd supplied. - #!important to fix. At the moment it could eat a further unflagged item in values later in the list which was intended for a different -commandprocessors member! - #add support for -commandprocessors {-cmd {-cmd -othercmd "default"}} to be a safe way to specify a linked -flag move that does the same. - proc allocate_arguments {PROCESSORS solos values cf_args caller} { - set runid [lindex [split [namespace tail $PROCESSORS] _] 1] ;# objname is of form PROCESSORS_pid-threadid-counter where "PROCESSORS_" is a literal - #puts stderr ">>>>>>> solos: $solos" - dict set debugc -debugargs [dict get $cf_args -debugargs] - dict set debugc -source "allocate_arguments $caller" - - set defaults [dict get $cf_args -defaults] - - set cmdprocessor_records [$PROCESSORS get_commandspecs] - - - set sep "\uFFFE" ;#argument-subargument separator (choose something else if this causes problems.. but we want something unlikely (or preferably impossible?) to be in a commandline, ideally a single character, and which at least shows something on screen during debug) - set sepstr "\\uFFFE" ;#for human readable error msg - #\u001E was tried and doesn't output on some terminals) - - set remaining_unflagged [dict create] - - set extra_flags_from_positionals [list] ;#values moved to -values - set moved_to_flagged [dict create] - - #implied_ are values supplied from defaults when a flag or operand was not found - set implied_flagged [list] - set implied_unflagged [list] - - - set dispatch [dict create] - #sanitize and raise error if sep somehow in values - if {[string first $sep $cmdprocessor_records] >= 0} { - do_error "allocate_arguments flags error separator '$sep' ($sepstr) found in values " - } - #-------------------------------------- - set VMAP [flagfilter::class_vmap create flagfilter::VMAP_$runid $values] - #-------------------------------------- - - set unconsumed_flags_and_values [list] - set unflagged [dict create] - - ###################### - #main -commandprocessors loop which scans the valuelist - set values_index 0 ;#track where we are up to as we allocate values to unflagged elements - set source_values $values ;#start with all including -flagged - - #todo - get rid of most of these flags last_x_was etc - and just do lookups into the v_map - # as this will probably involve *lots* of small functiona calls - keep this boolean version and check for performance issues. - set a_index 0 - set is_args_flag 0 - set last_arg_was_paramflag 0 ;#a flag that expects a parameter to follow - set last_arg_was_solo 0 - set solo_flags [dict keys $solos] ;#solos is a dict of -flag (preprocessed) - set end_of_options 0 - set end_of_options_index -1 ;#as later processors can rescan - we need to make sure they only look at arguments after this point - set last_p_found [dict create by "" index "" item ""] - set sequence 0 - set argerrors [list] ;#despite being a list - we will break out at first entry and return for now. - set parsestatus "ok" - - #set LAUNCHED [oolib::collection create col_processors_launched_$runid] - #set MATCHED [oolib::collection create col_processors_matched_$runid] - #oo::objdefine col_processors_matched_$runid { - # method test {} { - # return 1 - # } - #} - - #set objp [$PROCESSORS object_from_record $p] ;#temp convenience - - foreach objp [$PROCESSORS items] { - set objparent [$objp parent] - #$LAUNCHED add $objp [$objp name] - set p [$objp get_def] ;#individual record e.g {mycmd {match run singleopts {-x}}} or {tail_processor {}} - - lassign $p parentname pinfo - set is_sub [$objp is_sub] ;#is subargument - should look to see if last related spec got a value and abort if not. - set is_p_flag [$objp is_flag] ;#sub can be a flag even if parent isn't - set processorname [$objp name] - if {[$objp is_sub]} { - if {![[$objp parent] found_match]} { - continue - } - set p_sub [dict get $pinfo sub] - } - do_debug 3 $debugc " =========================>> p $p sequence:$sequence a_index $a_index" - - if {$processorname in [list "global" "tail_processor"]} { - dict set last_p_found by $processorname - #dict set last_p_found index $a_index - #dict set last_p_found item $a - } - # -format {x {sub y default "default"}} means y is dependent on x being present and shouldn't eat if the next value isn't flaglike - # -format {-x {sub -y}} does the same for moving positionals to the flagged list. - - - #set remaining_values [lrange $source_values $a_index end] - ##################################### - # full rescans for later processors - set remaining_values $source_values ;#source_values shrinks as commands take arguments - set a_index 0 - ##################################### - - do_debug 3 $debugc "-------->________>p '$processorname' remaining vals $remaining_values" - - #!todo - use v_map as an extra determinant to stop sequence for a command-set. (don't extend beyond where args have already been snipped by another command) - if {[$objp name] eq "tail_processor"} { - set mapcopy [flagfilter::class_vmap new {}] ;#no need to supply values as we are copying data from $VMAP - $VMAP copy_to $mapcopy - $objp set_map_object $mapcopy - } else { - $objp set_map_object $VMAP - } - foreach a $remaining_values { - set argnum [[$objp get_map_object] argnum_from_remaining_posn $a_index] - if {![string is integer -strict $argnum]} { - error "arg '$a' scan_index:$a_index - calculated argnum:'$argnum' is invalid" - - } - set sub_operand 0 - do_debug 3 $debugc "$argnum >eoptions_idx:$end_of_options_index a_index:$a_index __________________________________________________________a $a" - if {$end_of_options_index > -1} { - set end_of_options [expr {$a_index >= $end_of_options_index}] - } - - #review - data with leading - may be unintentionally interpreted as a flag - if {[string trim $a] eq "--"} { - #generally means end of options processing.. - #review - pass -- through?? - set last_arg_was_paramflag 0 ;#we don't treat first arg following end_of_options as belonging to the flag! - it is potentially an operand to the command - set is_solo_flag 0 - set end_of_options 1 - set end_of_options_index $a_index - #if {[lindex $p 0] eq "tail_processor"} { - $objp allocate $argnum "endofoptions" $a - set source_values [lreplace $source_values[set source_values {}] $a_index $a_index] ;#inlineK - incr a_index -1 - #} - } else { - if {($last_arg_was_paramflag) && ([$objp arg_is_defined_solo_to_me $a])} { - #last flag expecting param - but this flag *known* to be solo - #keep it simple and break out at first solo_flag related error ...unless it is trailing flag in the list - lappend argerrors [list flagerror solo_flag_following_non_solo_flag bad_flag $a] - set last_arg_was_solo 1 - break - } - #set is_solo_flag [expr {($a in $solo_flags)}] - #set is_solo_flag [is_this_flag_solo $a $solo_flags $objp] - set is_solo_flag [$objp arg_is_defined_solo_to_me $a] - - if {!$end_of_options} { - if {!$last_arg_was_paramflag} { - if {!$is_solo_flag} { - set is_args_flag [is_candidate_toplevel_param_flag $a $solo_flags $cmdprocessor_records] - #set is_args_flag [string match -* $a] - } - if {$is_args_flag || $is_solo_flag} { - if {[dict get $last_p_found by] eq $processorname} { - if {![is_this_flag_for_me $a $objp $cf_args]} { - if {$processorname ne "globalXXX"} { - do_debug 3 $debugc "----breaking--- $processorname already found a value [dict get $last_p_found item] and has now hit an unrecognized option: $a" - break - } - } - } - } - } else { - #last was flag expecting a param - set is_args_flag 0 - set is_solo_flag 0 - } - } else { - #end_of_options - ignore solo and other flags now. - set is_args_flag 0 - set is_solo_flag 0 - set last_arg_was_paramflag 0 - - } - - #puts stderr "!!!!!!!!!!!!!!!!!!1 here is_args_flag:$is_args_flag" - do_debug 3 $debugc " >________>________>is_p_flag: $is_p_flag last_arg_was_paramflag:$last_arg_was_paramflag is_args_flag:$is_args_flag is_solo: $is_solo_flag (soloflags:$solo_flags) a:$a " - if {!$is_args_flag && !$is_solo_flag } { - - if {!$last_arg_was_paramflag} { - if {[dict get $last_p_found by] eq $processorname} { - if {$processorname ne "tail_processor"} { - #we already found our unflagged value - and now we've hit another - time to break and hand it to a subcommand processor if any - do_debug 3 $debugc "----breaking--- $processorname already found a value [dict get $last_p_found item] and has now hit another value: $a" - break - } - } - set sequence_ok 1 ;#default assumption - set can_allocate [can_this_commandspec_allocate_this_arg $a $p $cf_args] - - if {$can_allocate} { - if {$is_sub} { - #!todo - use v_map as sequence terminator - #check if our find is in sequence - #we are only hunting non-flagged items and the the previous finder removes 1 from the source_values list - #therefore the a_index of our find should be the same if we are processing the very next argument. - #we have already checked that it was a related entity which found the last one. - #todo - review if it matters when parents/siblings don't eat all the way up to the next -flag. - #todo - implement a 'gather' key to keep eating in sequence and accumulate the values as a list - if {$a_index > [dict get $last_p_found index]} { - do_debug 3 $debugc "OUT OF SEQUENCE a_index:$a_index vs last_found index:[dict get $last_p_found index], $processorname disengaging - ignoring value $a and leaving it to the next processor" - set last_arg_was_paramflag 0 - do_debug 3 $debugc "<--- breaking --->" - break - } elseif {$a_index < [dict get $last_p_found index]} { - #too early.... found something before previous match - do_debug 3 $debugc "+++++++++++++++out of sequence $processorname - too early.. keeping scanning" - set sequence_ok 0 - } - if {$sequence_ok} { - set sub_operand 1 - } - } - } - - if {$can_allocate && $sequence_ok} { - #found a non-flagged value in the argumentlist to either reallocate to flagged values or to positional values - if {[dict exists $pinfo dispatch]} { - if {!$is_sub} { - #this must be the arg that caused the match - dict set dispatch $parentname [list command [dict get $pinfo dispatch] matched $a arguments [list] raw [list]] - } else { - #todo - lappend argerrors [list unsupported_dispatch $processorname] - } - } - if {$sub_operand} { - if {[dict exists $dispatch $parentname]} { - #todo - defaults? - add_dispatch_argument "dispatch" $parentname $processorname $a - add_dispatch_raw "dispatch" $parentname $a - } else { - #warning? - #lappend argerrors [list subcommand_unable_to_add_operand $processorname] - do_debug 3 $debugc "subcommand $processorname aborting scanning because parent command wasn't activated" - break - } - } - do_debug 2 $debugc " >+++++++>++++++++>++++++++>setting $processorname [if {$is_p_flag} {list -} {}]value $a" - if {$processorname eq "tail_processor"} { - set argnum [[$objp get_map_object] argnum_from_remaining_posn $a_index] - set argname arg$argnum - lappend remaining_unflagged $argname $a - lappend unconsumed_flags_and_values $a - dict set unflagged $argname $a - } elseif {$is_p_flag} { - $objp set_matched_argument $argnum $a - if {$is_sub} { - dict set extra_flags_from_positionals $p_sub $a - } else { - dict set extra_flags_from_positionals $parentname $a - } - lappend moved_to_flagged $processorname $a - #if has dependent commands ? - check for deep subcommand match? - } else { - $objp set_matched_argument $argnum $a - #lappend positional_values $a - dict set unflagged $processorname $a - } - do_debug 4 $debugc " >________>________>________>source_values :'$source_values'" - do_debug 3 $debugc " >________>________>________>source_values len:[llength $source_values] removing element $a_index val:[lindex $source_values $a_index]" - - #---------------------------- - dict set last_p_found by $processorname - dict set last_p_found index $a_index - dict set last_p_found item $a - #------------------------------ - $objp allocate $argnum "operand" $a - set source_values [lreplace $source_values[set source_values {}] $a_index $a_index] ;#inlineK - incr values_index ;#only increment when we allocate a value to one of the members of -commandprocessors - set last_arg_was_paramflag 0 - if {$processorname ne "tail_processor"} { - #don't break until we hit an unrecognized flag or another unflagged value - incr a_index -1 - #don't increment a_index before break, because we have shortened the list by 1. - #do_debug 3 $debugc "----breaking---" - #break - } else { - #decrement to compensate for shortened list because tail_processor continues to end - incr a_index -1 - } - } - - } else { - #last_arg_was_paramflag - set lastarg [dict get $last_p_found item] - #puts stdout "+++ lastarg: $lastarg source_values: [dict get $last_p_found source_values] a_index: $a_index" - if {$processorname eq "tail_processor"} { - lappend unconsumed_flags_and_values $a - } - if {([dict get $last_p_found by] eq $processorname) && [is_this_flag_for_me $lastarg $objp $cf_args]} { - update_dispatch_argument "dispatch" $parentname $lastarg $a - add_dispatch_raw "dispatch" $parentname $a - dict set last_p_found by $processorname - dict set last_p_found index $a_index - dict set last_p_found item $a - $objp allocate $argnum "flagvalue" $a - set source_values [lreplace $source_values[set source_values {}] $a_index $a_index] ;#inlineK - incr a_index -1 - } - set last_arg_was_paramflag 0 - } - } else { - # is a flag of some sort ({!$is_args_flag && !$is_solo_flag} = false) - if {$processorname eq "tail_processor"} { - lappend unconsumed_flags_and_values $a - } - if {([dict get $last_p_found by] eq $processorname) && [is_this_flag_for_me $a $objp $cf_args]} { - if {$is_solo_flag} { - add_dispatch_argument "dispatch" $parentname $a 1 - add_dispatch_raw "dispatch" $parentname $a - set last_arg_was_solo 1 - set last_arg_was_paramflag 0 - $objp allocate $argnum "soloflag" $a - } else { - add_dispatch_argument "dispatch" $parentname $a "" - add_dispatch_raw "dispatch" $parentname $a - set last_arg_was_solo 0 - set last_arg_was_paramflag 1 - $objp allocate $argnum "flag" $a - } - dict set last_p_found by $processorname - dict set last_p_found index $a_index - dict set last_p_found item $a - do_debug 4 $debugc " >2_______>________>________>source_values :'$source_values'" - do_debug 3 $debugc " >2_______>________>________>source_values len:[llength $source_values] removing element $a_index val:[lindex $source_values $a_index]" - set source_values [lreplace $source_values[set source_values {}] $a_index $a_index] ;#inlineK - incr a_index -1 - } else { - #auto alternate based on last value.. unless end_of_options - if {!$end_of_options} { - if {$a in $solo_flags} { - set last_arg_was_solo 1 - set last_arg_was_paramflag 0 - } else { - set last_arg_was_paramflag 1 - } - } - if {$a_index eq ([llength $source_values]-1)} { - #puts "XXXXXXXXXXXXXXXXXXX $a_index source_values:'$source_values'" - #if at end of list don't retain any last..was info. - set last_arg_was_solo 0 - set last_arg_was_paramflag 0 - } - #skip - don't eat - } - } - } - incr a_index - } - - if {![$objp found_match]} { - - #after break - we have retained vars: $parent, $sub_operand $pinfo $processorname etc - #didn't find an unflagged var - set a default if one was specified. - #do nothing otherwise - check_args will determine if it was -required etc. - #review - should only apply if parent cmd found something? - if {[dict exists $pinfo default]} { - set defaultval [dict get $pinfo default] - if {$is_p_flag} { - if {$is_sub} { - dict set extra_flags_from_positionals $p_sub $defaultval - } else { - dict set extra_flags_from_positionals $processorname $defaultval - } - #lappend moved_to_flagged $processorname $defaultval - lappend implied_flagged $processorname $defaultval - do_debug 3 $debugc "SETTING DEFAULT varname:$processorname $defaultval implied_flagged: $implied_flagged " - } else { - lappend implied_unflagged $processorname $defaultval - dict set unflagged $processorname $defaultval - do_debug 3 $debugc "SETTING DEFAULT varname:$processorname $defaultval moved_to_flagged: $moved_to_flagged " - } - - if {$is_sub && !$sub_operand} { - if {[dict exists $dispatch $parentname]} { - add_dispatch_argument "dispatch" $parentname $processorname $defaultval - } else { - lappend argerrors [list subcommand_unable_to_add_default_operand $processorname $defaultval] - } - } - } - } - - if {[$objp name] eq "tail_processor"} { - $VMAP update_map_from [$objp get_map_object] - } - - if {[llength $argerrors]} { - set parsestatus "error" - #abort processing at first error - we won't be able to make sense of the remaining args anyway - #even the tail_processor won't be able to classify reliably because flag meanings depend on the configured commands - break - } - } - - #assertion - should be none? - #set remaining_values [lrange $source_values $a_index end] - #do_debug 3 $debugc "-------->________>end of processing - remaining vals $remaining_values" - - do_debug 2 $debugc "========>=========>originals : $values" - do_debug 2 $debugc "[$VMAP get_map]" - do_debug 2 $debugc "========>=========>unconsumed: $unconsumed_flags_and_values" - - - - - - set all_flagged [$VMAP get_merged_flagged_by_class *] - set all_flagged_plus [concat $all_flagged $extra_flags_from_positionals] - - set all_flagged_list [$VMAP get_list_flagged_by_class *] - set all_flagged_list [concat $all_flagged_list $extra_flags_from_positionals] - - set remaining_flagged [$VMAP get_merged_flagged_by_class "unallocated"] - - set remaining_flagged_list [$VMAP get_list_flagged_by_class "unallocated"] - - - set unflagged_list_in_processing_order [dict values $unflagged] - set unflagged_list [$VMAP get_list_unflagged_by_class *] - - set unflagged_list_remaining [$VMAP get_list_unflagged_by_class "unallocated"] - - return [dict create \ - listremaining $unconsumed_flags_and_values \ - parseerrors $argerrors \ - parsestatus $parsestatus \ - flagged $all_flagged_plus \ - flaggedlist $all_flagged_list \ - flaggedremaining $remaining_flagged \ - flaggedlistremaining $remaining_flagged_list \ - unflagged $unflagged \ - unflaggedlist $unflagged_list \ - unflaggedremaining $remaining_unflagged \ - unflaggedlistremaining $unflagged_list_remaining \ - flaggednew $extra_flags_from_positionals \ - arglist [concat $unflagged_list_in_processing_order $all_flagged] \ - arglistremaining [concat $unflagged_list_remaining $remaining_flagged] \ - impliedflagged $implied_flagged \ - impliedunflagged $implied_unflagged \ - dispatch $dispatch \ - classifications [$VMAP get_map] \ - gridstring "\n[$VMAP grid]" \ - vmapobject "flagfilter::VMAP_$runid" \ - ] - } - - - - - - - - - - - - #specialisation for collection class to contain commandprocessors - # we expect to use only a single instance of this - oo::class create col_allprocessors { - superclass oolib::collection - variable o_commandspecs - method add_processor {p} { - my add $p [$p name] - if {[$p is_sub]} { - set parentname [$p parentname] - set obj_parent [my item $parentname] - set col_siblings [$obj_parent children] - $col_siblings add $p [$p name] - } - } - method set_commandspecs {cspecs} { - set o_commandspecs $cspecs - } - method get_commandspecs {} { - set o_commandspecs - } - #treating as singleton.. todo tidy - method name_from_record {rec} { - lassign $rec parentname pinfo - if {[dict exists $pinfo sub]} { - set name [join [list $parentname [dict get $pinfo sub]] .] - } else { - set name $parentname - } - return $name - } - method object_from_record {rec} { - set name [my name_from_record $rec] - return [my item $name] - } - #basic check if arg may consume the following one - not based on any specific info from processors - method arg_appears_standalone {f} { - if {(![string match "-*" $f]) && (![string match "/*" $f])} { - #not even flaglike - return 1 - } - if {$f in {- --}} { - return 1 - } - } - #does any processor define it as solo - method flag_can_be_solo {f} { - foreach objp [my items] { - if {[$objp arg_is_defined_solo_to_me $f]} { - return 1 - } - } - return 0 - } - } - oo::class create col_parents { - superclass oolib::collection - method add_parent {p} { - if {[$p is_sub]} { - error "cannot add a sub-processor to the main parents collection" - } - my add $p [$p name] - } - } - #each parent processor has a children collection which can only accept processors with sub defined. - oo::class create col_childprocessors { - superclass oolib::collection - variable o_ownername - method set_owner {parentname} { - set o_ownername $parentname - } - #owner of the collection (a parent processor) - method owner {} { - return $o_ownername - } - method add_processor {p} { - if {![$p is_sub]} { - error "processor must have 'sub' element to add to the parent's collection" - } - #check name matches this parent.. - - my add $p [$p name] - } - } - - #todo - rename 'cprocessor' is misleading - oo::class create cprocessor { - variable o_runid - variable o_name - variable o_definition - variable o_pinfo - variable o_parentname - variable o_is_sub - variable o_col_children - variable o_mashopts - variable o_singleopts - variable o_pairopts - variable o_longopts - variable o_found_match ;#we directly matched a command trigger or positional argument - variable o_matched_argument - variable o_matched_argnum - variable o_matchspec - variable o_vmap - constructor {definition runid} { - set o_vmap "" - set o_definition $definition - set o_runid $runid - if {([llength $o_definition] < 2) || ([llength [lindex $o_definition 0]] != 1)} { - error "[self class].constructor Unable to interpret definition '$o_definition'" - } - lassign $o_definition o_parentname o_pinfo - if {([llength $o_pinfo] %2) != 0} { - error "[self class].constructor second element of definition '$o_definition' not a dict" - } - set o_is_sub [dict exists $o_pinfo sub] - if {!$o_is_sub} { - set o_name $o_parentname - set o_col_children [::flagfilter::col_childprocessors new] - $o_col_children set_owner $o_name - } else { - set o_name [join [list $o_parentname [dict get $o_pinfo sub]] .] - } - if {[dict exists $o_pinfo match]} { - set o_matchspec [dict get $o_pinfo match] - } else { - #review - unix paths? conflict with windows style flag such as /w - #must accept empty string - set o_matchspec {^[^-^/].*|^$} ;#match anything that isn't flaglike - } - set o_found_match 0 - set o_matched_argument "" ;#need o_found_match to differentiate match of empty string - set o_matched_argnum -1 - #load mashopts etc at construction time as they're static - set o_mashopts [list] - set o_singleopts [list] - set o_pairopts [list] - set o_longopts [list] - if {[dict exists $o_pinfo mashopts]} { - lappend o_mashopts {*}[dict get $o_pinfo mashopts] - } - if {[dict exists $o_pinfo singleopts]} { - lappend o_singleopts {*}[dict get $o_pinfo singleopts] - } - if {[dict exists $o_pinfo pairopts]} { - lappend o_pairopts {*}[dict get $o_pinfo pairopts] - } - if {[dict exists $o_pinfo longopts]} { - lappend o_longopts {*}[dict get $o_pinfo longopts] - } - } - destructor { - catch {$o_vmap destroy} - if {!$o_is_sub} { - $o_col_children destroy - } - } - - method name {} { - return $o_name - } - #open things up during oo transition.. - method get_def {} { - return $o_definition - } - method is_flag {} { - if {[my is_sub]} { - #sub can be a flag even if parent isn't - set subname [dict get $o_pinfo sub] - return [string match -* $subname] - } else { - return [string match -* $o_name] - } - } - method has_same_parent {other} { - return [expr {[other parentname] eq $o_parentname}] - } - method is_sub {} { - return $o_is_sub - } - - method set_map_object {map} { - set o_vmap $map - } - method get_map_object {} { - return $o_vmap - } - method allocate {argnum type val} { - if {$o_vmap eq ""} { - error "[self class].allocate ($o_name) vmap is not set." - } - $o_vmap allocate [self object] $argnum $type $val - } - - method found_match {} { - return $o_found_match - } - method matched_argument {} { - return $o_matched_argument - } - method matched_argnum {} { - return $o_matched_argnum - } - method set_matched_argument {argnum a} { - #could be empty string - if {$o_found_match} { - error "[self object].set_matched_argument processor:$o_name already found match '$o_matched_argument' - cannot set again" - } - if {![my can_match $a]} { - error "error [self class].set_matched_argument processor:$o_name cannot match '$a' (matchspec: $o_matchspec)" - } - set o_found_match 1 - set o_matched_argument $a - set o_matched_argnum $argnum - } - method has_explicit_matchspec {} { - return [dict exists $o_pinfo match] - } - method matchspec {} { - return $o_matchspec - } - method can_match {a} { - if {!$o_found_match} { - foreach m $o_matchspec { - if {[regexp -- $m $a]} { - return 1 - } - } - return 0 - } else { - return 0 - } - } - #?? - method can_allocate_flags {} { - } - - - - - - #if we are a parent - this is own name - method parentname {} { - return $o_parentname - } - method parent {} { - return [::flagfilter::obj::PARENTS_$o_runid item $o_parentname] - } - method is_parent {} { - return [expr {!$o_is_sub}] - } - method children {} { - if {!$o_is_sub} { - return $o_col_children - } else { - #raise error? - return "" - } - } - method mashopts {} { - return $o_mashopts - } - method singleopts {} { - return $o_singleopts - } - method pairopts {} { - return $o_pairopts - } - method longopts {} { - return $o_longopts - } - - #whether flag categorized as solo by this processor - method arg_is_defined_solo_to_me {a} { - if {(![string match "-*" $a]) && (![string match "/*" $a])} { - #not even flaglike - return 0 - } - if {[my can_match $a]} { - return 0 - } - if {$a in {- --}} { - #specials not defined as solos - return 0 - } - - if {$o_name eq "global"} { - - } elseif {$o_name eq "tail_processor"} { - - } - - if {$a in $o_singleopts} { - return 1 - } - if {"any" in $o_singleopts} { - return 1 - } - set equalposn [string first "=" $a] - if {$equalposn >=1} { - if {"any" in $o_longopts} { - return 1 - } else { - set namepart [string range $a 0 $equalposn-1] - foreach lo $o_longopts { - if {[string match "${namepart}=*" $lo]} { - return 1 - } - } - } - } - #Flag could still be part of a solo if it is in mashopts *and* has a value following it as part of the mash - #- but if it's a pairopt, but not mashable - we can rule it out now - if {($a in $o_pairopts) && ($a ni $o_mashopts)} { - return 0 - } - set flagletters [split [string range $a 1 end] ""] - set posn 1 - #trailing letters may legitimately not be in mashopts if they are part of a mashed value - #we can return 0 if we hit a non-mash flag first.. but at each mashflag we need to test if we can classify as definitely solo or not, or else keep processing - foreach l $flagletters { - if {"-$l" ni $o_mashopts} { - #presumably an ordinary flag not-known to us - return 0 - } else { - if {"-$l" in $o_pairopts} { - if {$posn == [llength $flagletters]} { - #in pairopts and mash - but no value for it in the mash - thefore not a solo - return 0 - } else { - #entire tail is the value - this letter is effectively solo - return 1 - } - } elseif {"-$l" in $o_singleopts} { - #not allowed to take a value - keep processing letters - } else { - #can take a value! but not if at very end of mash. Either way This is a solo - return 1 - } - } - } - #This object should not treat the flag as a known solo - #- so if it is allowed to consume it, it may fall back on examining the subsequent argument's flaginess(?) - return 0 - } - - - method get_opts {} { - return [list mashopts $o_mashopts singleopts $o_singleopts pairopts $o_pairopts longopts $o_longopts] - } - #include parent opts - #we use the terminology 'option' for "-" prefixed items belonging to a -commandprocessors spec as opposed to more general -flags - #Note - this may also be called on the default "tail_processor", which will return empty sets, or an overridden tail_processor which may have data - method get_combined_opts {} { - set objparent [::flagfilter::obj::PARENTS_$o_runid item $o_parentname] - set parentopts [$objparent get_opts] - set mashopts [dict get $parentopts mashopts] - set singleopts [dict get $parentopts singleopts] - set pairopts [dict get $parentopts pairopts] - set longopts [dict get $parentopts longopts] - if {[my is_sub]} { - #this spec is a sub - set subopts [my get_opts] - #does order matter? could use struct::set union ? - foreach m [dict get $subopts mashopts] { - if {$m ni $mashopts} { - lappend mashopts $m - } - } - foreach s [dict get $subopts singleopts] { - if {$s ni $singleopts} { - lappend singleopts $s - } - } - foreach po [dict get $subopts pairopts] { - if {$po ni $pairopts} { - lappend pairopts $po - } - } - foreach lo [dict get $subopts longopts] { - if {$lo ni $longopts} { - lappend longopts $lo - } - } - - } - return [list mashopts $mashopts singleopts $singleopts pairopts $pairopts longopts $longopts] - } - - } - - - - - - - - - - - - proc get_command_info {cmdname cspecs} { - foreach item $cspecs { - lassign $item cmd specinfo - if {$cmd eq $cmdname && [dict exists $specinfo dispatch]} { - return $specinfo - } - } - return [list] - } - #### check_flags - # does not support unvalued flags - unless explicitly specified in -soloflags (global) or in -singleopts for a commandprocessor - #e.g not supported: v1 v2 -arg1 arg1val -debug -anotherflag anotherflagval - # - unless -soloflags is something like -soloflags {-debug} or -soloflags {{-debug 1}} where 1 is the default. In this case - we can no longer support accepting a value for -soloflags - the processor will not assign it an argument from the commandline. - #e.g not supported (unless -debug in -soloflags): v1 v2 -arg1 arg1val -anotherflag anotherflagval -debug - #e.g supported: v2 v2 -arg1 arg1val -debug 1 -anotherflag anotherflagval - # supports positional arguments - but only if specified in -commandprocessors - # todo - # - supports -- for treating following arg as value even if it looks like a flag - # - supports - for reading stdin - # expects at least -values - # other options -caller -defaults -required -extras -commandprocessors - # -soloflags (these are flags that *must* be solo - ie they cannot take an argument ) if no default specified they are boolean defaulting to 1, repeated instances in -values will be appended to a list. - # The only flag that can be a mix of solo or not, is the very last flag in the values list. In this case it must not be in the -soloflags list, but it will default to a boolean 1 to indicate presence. - proc check_flags {args} { - set runid [flagfilter::get_new_runid] - #################################################### - #puts "Entered checkflags, args $args" - set distanceToTop [info level] - set callerlist [list] - set was_dispatched_by_another 0 ;#used to - for {set i 1} {$i < $distanceToTop} {incr i} { - set callerlevel [expr {$distanceToTop - $i}] - set callerinfo [info level $callerlevel] - set firstword [lindex $callerinfo 0] - if {[string match "*check_flags*" $firstword]} { - set was_dispatched_by_another 1 - } - lappend callerlist $firstword - } - #puts stdout "callerlist: $callerlist" - - #first handle args for check_flags itself - if {[catch {lindex [info level -1] 0} caller]} { - set caller "" - } - #puts stderr ">>>>check_flags caller $caller" - get_one_paired_flag_value {-x 1} -x ;# - - #manually check for -caller even if unbalanced args - #we only need to use get_one_paired_flag_value because we haven't yet checked args is a properly formed paired list and if -caller is present we want to use it for clearer error messages. - #use normal dict operations to retrieve other flags. - #if failed to retrieve.. fall through to checks below - if {![catch {get_one_paired_flag_value $args -caller} flag_value_result]} { - set caller $flag_value_result - } - #puts stderr ">>>>check_flags caller $caller" - - - - - set cf_defaults [dict create\ - -caller $caller\ - -return [list arglistremaining]\ - -match [list]\ - -commandprocessors [list]\ - -soloflags [list]\ - -extras [list]\ - -defaults [list]\ - -required [list]\ - -values \uFFFF\ - -debugargs 0\ - ] - dict set cf_defaults -debugargsonerror 1 ;#error level to use when dispatch error occurs.. will not set lower than -debugargs - - - - if {([llength $args] % 2) != 0} { - do_error "check_flags error when called from '$caller' :check_flags must be called with even number of arguments of form: -flag value Valid flags are: '[dict keys $cf_defaults]' \n got: $args" - } - set cf_args $cf_defaults - foreach {k v} $args { - switch -- $k { - -caller - -return - -match - -commandprocessors - -soloflags - -extras - -defaults - -required - -values - -debugargs - -debugargsonerror { - dict set cf_args $k $v - } - default { - do_error "check_flags error when called from ${caller}: Unknown option '$k': must be one of '[dict keys $cf_defaults]' \nIf calling check_flags directly, put args being checked in -values {...}" - } - } - } - unset args - #################################################### - #now look at -values etc that check_flags is checking - - set caller [dict get $cf_args -caller] - - set debugargs [dict get $cf_args -debugargs] - dict set debugc -debugargs [dict get $cf_args -debugargs] - dict set debugc -source "check_flags $caller" - do_debug 1 $debugc "DEBUG-START $caller" - - set returnkey [dict get $cf_args -return] - set defaults [dict get $cf_args -defaults] - if {([llength $defaults] % 2) != 0} { - do_error "check_flags error when called from '$caller' :-defaults must be a list containing an even number of arguments of form: -flag value'" - } - set required [dict get $cf_args -required] - - - set acceptextra [dict get $cf_args -extras] - - set supplied [string trim [dict get $cf_args -values]] - set soloflags [dict get $cf_args -soloflags] ;#By their nature - solo flags are unlikely to be automatically 'required' - review - set solos_with_defaults [list] - foreach solo_spec $soloflags { - if {[llength $solo_spec] == 1} { - lappend solos_with_defaults $solo_spec 1 - } else { - lappend solos_with_defaults [lindex $solo_spec 0] [lindex $solo_spec 1] - } - - } - - if {$debugargs >= 3} { - set prefix "| $caller>" - puts -nonewline stderr "$prefix [string repeat - 30]\n" - puts -nonewline stderr "$prefix input\n" - puts -nonewline stderr "$prefix [string repeat - 30]\n" - #puts stderr "$caller $cf_args" - dict for {k v} $cf_args { - if {$k ne "-commandprocessors"} { - puts -nonewline stderr "$prefix \[$k\]\n" - puts -nonewline stderr "$prefix $v\n" - } - } - if {$debugargs >=4} { - puts -nonewline stderr "$prefix \[-commandprocessors\]\n" - foreach record [dict get $cf_args -commandprocessors] { - puts -nonewline stderr "$prefix $record\n" - } - } - puts -nonewline stderr "$prefix [string repeat - 30]\n" - #dict for {key val} $cf_args { - # puts stderr " $key" - # puts stderr " $val" - #} - } - - - ################################################################################################## - # allocate_arguments does the main work of processing non-flagged items in the main supplied argument list into flagged versions depending on the specs in -commandprocessors - # It sets defaults only for those arguments processed by a '-commandprocessors' spec. - # We must supply it with the -soloflags info because the solo flags affect what is considered an operand. - set command_specs [dict get $cf_args -commandprocessors] ;#may be empty list - that's ok - it will still populate the 'flagged' and 'arglist' return-dict members. - - #some of these are keys returned by allocate_arguments - # - some (e.g supplied) are added by check_flags - # This list is the list of -return values that can be used with check_args - set flaginfo_returns [list \ - parseerrors \ - parsestatus \ - flagged \ - flaggedremaining \ - flaggednew \ - unflagged \ - unflaggedremaining \ - unflaggedlistremaining \ - listremaining \ - arglist \ - arglistremaining \ - impliedunflagged \ - impliedflagged \ - classifications \ - gridstring \ - ranges \ - dispatch \ - dispatchstatuslist \ - dispatchresultlist \ - dispatchstatus \ - supplied \ - defaults \ - status \ - vmapobject \ - ] - - set PROCESSORS [col_allprocessors create ::flagfilter::obj::PROCESSORS_$runid] - set PARENTS [col_parents create ::flagfilter::obj::PARENTS_$runid] - - # - #set command_specs [concat [list {global {}}] $command_specs] - lappend command_specs {tail_processor {}} - - foreach cspec $command_specs { - set obj [cprocessor new $cspec $runid] ;#runid gives access to the context-objects PROCESSORS_runid & PARENTS_runid - if {[$obj is_parent]} { - $PARENTS add_parent $obj - } - #do_debug 1 $debugc "CONFIGURING OBJECT for commandprocessor [$obj name]" - $PROCESSORS add_processor $obj - } - do_debug 1 $debugc "ADDED [$PROCESSORS count] processors to main commandprocessor collection" - do_debug 1 $debugc "ADDED [$PARENTS count] processors to the parents collection" - $PROCESSORS set_commandspecs $command_specs - - #allocate_arguments uses the PROCESSORS object - set processed_arguments [allocate_arguments $PROCESSORS $solos_with_defaults $supplied $cf_args $caller] - #set processed_arguments [allocate_arguments {} $supplied] - - set newly_flagged_positionals [dict get $processed_arguments flaggednew] - set unflaggedremaining [dict get $processed_arguments unflaggedremaining] - set unflaggedlistremaining [dict get $processed_arguments unflaggedlistremaining] - set dispatch [dict get $processed_arguments dispatch] - set flaggedremaining [dict get $processed_arguments flaggedremaining] - set RETURNED_VMAP [dict get $processed_arguments vmapobject] - - - - if {$debugargs >= 3} { - set prefix "| $caller>" - puts -nonewline stderr "$prefix [string repeat - 30]\n" - puts -nonewline stderr "$prefix output\n" - puts -nonewline stderr "$prefix [string repeat - 30]\n" - #puts stderr "processed_arguments: $processed_arguments" - dict for {key val} $processed_arguments { - puts -nonewline stderr "$prefix $key\n" - puts -nonewline stderr "$prefix $val\n" - } - puts -nonewline stderr "$prefix [string repeat - 30]\n" - } - - ################################################################################################## - - - - - - if {![llength $newly_flagged_positionals]} { - if {($supplied eq "\uFFFF") || ![llength $supplied]} { - #do_error "check_flags error when called from ${caller}: missing or empty -values" - } - } - - #probably not something to enforce... we might pass on unbalanced lists to other check_args etc. - #if {([llength $supplied] % 2) != 0} { - # do_error "${caller}: Error. $caller must be called with even number of arguments of form: -flag value Valid flags are: '[dict keys $defaults]'\n received values: $supplied" - #} - - - - set new_arg_list [dict get $processed_arguments arglistremaining] - set flagged_list [dict get $processed_arguments flagged] - #set suppliedkeys_with_extrakeys [concat [dict keys $supplied] [dict keys $newly_flagged_positionals]] - #puts stdout "suppliedkeys and new keys: $suppliedkeys_with_extrakeys" - - #todo - add flaggednew to required if all was specified? - #check invalid flags if not indicated in -extras , either explicitly or with 'extra' - set flags_from_required [get_flagged_only $required {}] - #set known_flags [lsort -unique -nocase [concat [dict keys $defaults] $flags_from_required $soloflags]] ;#why -nocase? why should -l and -L collapse to the uppercase version? - set known_flags [punk::lib::lunique_unordered [concat [dict keys $defaults] $flags_from_required $soloflags ]] - foreach spec $command_specs { - lassign $spec parentname pinfo - if {[string match -* $parentname] && $parentname ni $known_flags} { - lappend known_flags $parentname - } - if {[dict exists $pinfo sub]} { - if {[string match -* [dict get $pinfo sub]]} { - lappend known_flags [dict get $pinfo sub] - } - } - } - do_debug 2 $debugc "------------------->known_flags: $known_flags soloflags:$soloflags" - set invalid_flags [list] - if {"all" ni [string tolower $acceptextra]} { - if {"none" in [string tolower $acceptextra]} { - set ok_extras [list] - } elseif {[llength $acceptextra]} { - set ok_extras $acceptextra - } - #todo - #puts stderr " check_flags - temporary disable of checking for invalid flags" - set pairflagged $flagged_list - foreach {f v} $pairflagged { - if {$f ni $acceptextra && $f ni $known_flags} { - lappend invalid_flags $f - } - } - } - if {[llength $invalid_flags]} { - do_error "check_flags $caller error when called from ${caller}: unknown flags '$invalid_flags'" - } - - set calc_required [list] - set keywords_in_required [lsearch -inline -all -not $required -*] - set bad_keywords_in_required [lsearch -regexp -nocase -all -inline -not $keywords_in_required "all|none"] - if {[llength $bad_keywords_in_required]} { - do_error "check_flags error when called from ${caller}: bad flags in '-required' it must be a list of flags of the form -flagname or ONLY one of the keywords 'none' or 'all'" - } - #keywords_in_required now known to be only comprised of (possibly case variant) values of all|none - if {[llength $keywords_in_required] > 1} { - do_error "check_flags error when called from ${caller}: specifying both 'none' and 'all' in -required is not valid, and repeated values are not valid." - } - if {"none" eq [string tolower [lindex $keywords_in_required 0]]} { - set calc_required [list] - } - set flags [lsearch -inline -all $required -*] - - if {[llength $required]} { - if {[lsearch -nocase $keywords_in_required "all"] >= 0} { - #'all' can be present with other flags - and indicates we also require all the flags from -defaults - dict for {k -} $defaults { - if {$k ni $calc_required} { - lappend calc_required $k - } - } - } - } - - set classifications [dict get $processed_arguments classifications] ;#assertion - ordered by numerically increasing key representing positions in supplied argument list - set rangesets [$RETURNED_VMAP get_ranges_from_classifications $classifications] - set ranges [dict get $rangesets -ranges] - set rangesbytype [dict get $rangesets -rangesbytype] ;#unallocated are split into flag,operand and endofoptions - further splitting is easy enough to do by looking up the classifications list for each position in the supplied arg list. - #tailflags are the same for all dispatch items - set tailflagspaired [tailflagspaired $defaults $supplied $classifications $rangesbytype] - - - set dict_supplied [dict create supplied $supplied] - set dict_defaults [dict create defaults $defaults] - set dict_ranges [dict create ranges $ranges] - set dict_rangesbytype [dict create rangesbytype $rangesbytype] - set raise_dispatch_error_instead_of_return "" - set dict_dispatch_results [list dispatchstatuslist [list] dispatchresultlist [list] dispatchstatus "ok"] - #todo - only dispatch if no unallocated args (must get tail_processor to allocate known flags to 'global') - if {[llength $dispatch]} { - set dispatchstatuslist [list] - set dispatchresultlist [list] - set dispatchstatus "ok" - #each dispatch entry is a commandname and dict - #set dispatchrecord [lrange $dispatch 0 1] - set re_argnum {%arg([0-9^%]+)%} - set re_argtake {%argtake([0-9^%]+)%} - set re_dquotedparts {(?:(?:\"[^\"]*\")|(?:\"[^\"]*"))|(?:\S*[^ \"])} ;#for use with regexp -all -inline - #e.g {"a b" 'b x' "x cd "e f" g a} -> {"a b"} 'b x' {"x cd "} e f {" g a} - #dumb-editor rebalancing quote for above comment " - foreach {parentname dispatchrecord} $dispatch { - set commandinfo [get_command_info $parentname $command_specs] - - do_debug 1 $debugc ">>>>>DISPATCHRECORD: $dispatchrecord" - - # e.g lscmd lscmd natsortcommandline_ls lscmd.dir x - - do_debug 2 $debugc "commandinfo for $parentname: $commandinfo" - set command [dict get $dispatchrecord command] - #support for %x% placeholders in dispatchrecord command - set command [string map {%match% %matched%} $command] ;#alias - set command [string map [list %matched% [dict get $dispatchrecord matched]] $command] - - set argnum_indices [regexp -indices -all -inline $re_argnum $command] - if {[llength $argnum_indices]} { - foreach {argx_indices x_indices} $argnum_indices { - #argx eg %arg12% - set argx [string range $command {*}$argx_indices] - set x [string range $command {*}$x_indices] - set command [string map [list $argx [lindex [dict get $dispatchrecord arguments] $x]] $command] - } - } - - set argsreduced [dict get $dispatchrecord arguments] - #set rawparts [regexp -all -inline $re_dquotedparts [dict get $dispatchrecord raw]] - - #review! - #how will this behave differently on unix - package require punk::winrun - set rawparts [punk::winrun::unquote_wintcl [dict get $dispatchrecord raw]] - #set argtake_indices [regexp -indices -all -inline $re_argtake $command] - - - set start 0 - while {[regexp -start $start -indices $re_argtake $command argx_indices x_indices]} { - #argx eg %argtake12% - set argx [string range $command {*}$argx_indices] - set x [string range $command {*}$x_indices] - set argval [lindex [dict get $dispatchrecord arguments] $x] - set replacementlen [string length $argval] - set command [string map [list $argx $argval] $command] - set start [expr {[lindex $argx_indices 0] + $replacementlen}] - set argsreduced [lremove $argsreduced $x] - set rawparts [lremove $rawparts $x] - } - dict set dispatchrecord arguments $argsreduced - if {$start > 0} { - set rawreduced [join $rawparts] - dict set dispatchrecord raw $rawreduced - } - - set argvals [dict get $dispatchrecord arguments] - set matched_operands [list] - set matched_opts [list] - set matched_in_order [list] - set prefix "${parentname}." - set prefixlen [string length $prefix] - foreach {k v} $argvals { - #puts "$$$$ $k" - if {[string equal -length $prefixlen $prefix $k]} { - #key is prefixed with "commandname." - set k [string replace $k 0 $prefixlen-1] - } - #todo - -- ? - if {[string match -* $k]} { - lappend matched_opts $k $v - lappend matched_in_order $k $v - } else { - set kparts [split $k .] - lappend matched_operands $v - lappend matched_in_order $v - } - } - - if {![dict exists $commandinfo dispatchtype]} { - set dispatchtype tcl - } else { - set dispatchtype [dict get $commandinfo dispatchtype] - } - if {![dict exists $commandinfo dispatchglobal]} { - if {$dispatchtype eq "tcl"} { - set dispatchglobal 1 - } else { - set dispatchglobal 0 - } - } else { - set dispatchglobal [dict get $commandinfo dispatchglobal] - } - #generally we only want to dispatch remaining flagged, and only at the tail end.(as opposed to flags occurring between command groups) - # -It doesn't usually make much sense to dispatch remaining unflagged items, and it would be rare to require flags occurring before the command. - #however - there are potential commands such as help, dryrun or maybe an analysis command that may need to see unconsumed operands or even look 'back' at prior items - ##update 2023-03 - we definitely want to look back to prior non-matches when we match on a script e.g tclsh8.6 -someflag etc xxx.tcl scriptarg1 -etc - # if we match and dispatch on *.tcl - then we may need 'tclsh8.6 -someflag etc' as the interpreter (possibly with arguments) to use. - # we may need a 'script' dispatchtype (as well as the option to just pass these prior arguments as additional options for some other dispatchtypes) - # - # todo - add supported dispatchglobal values such as all, pre, post, allpre, allpost, and classifications - # where pre & post are only those occurring directly before and after the command and its args, i.e not extending beyond any prior or subsequent other command. - # classifications would be flagged as -classifications $classifications whereas pre and post would be added directly if specified singly, or flagged with -pre, -post etc if multiple are specified - # Those beginning with 'all' should also be wrapped in flags, because potentially they come from disjointed sections of the argumentlist - # - and we generally shouldn't supply arguments next to each other that weren't contiguous in the original list - # The 1,true,yes,tailflagspaired value is designed for the usecase where a common set of tail flags e.g -debug can apply to any commands matched by the filter. - # tail = all unallocated args after final command, including operands and end-of-options '--' (todo) - # tailflags = all unallocated *contiguous* flags after the final command and final operands. (ie it will deliberately miss flags following last command if there is a later operand) (todo) - # tailflagspaired = same as tailflags, but any solo-flags are defaulted to 1 (flags not merged, so there might be duplicate keys) so that it's a fully paired list - # In other situations - post may make sense to get the very next set of unconsumed arguments. - if {[string tolower $dispatchglobal] in [list 1 true yes tailflagspaired]} { - set command_range_posn [lsearch -index 1 $ranges $parentname] - set extraflags $tailflagspaired - } else { - set extraflags [list] - } - - #jn concat allows $command to itself be a list - ##tcl dispatchtype - dict set dispatchrecord dispatchtype $dispatchtype - switch -- $dispatchtype { - tcl { - do_debug 1 $debugc "DISPATCHING with tcl arg order: $command $matched_operands $matched_opts $extraflags" - #set commandline [list $command {*}$matched_operands {*}$matched_opts {*}$extraflags] - set commandline [concat $command $matched_operands $matched_opts $extraflags] - } - raw { - do_debug 1 $debugc "DISPATCHING with raw args : $command [dict get $dispatchrecord raw]" - #set commandline [list $command {*}[dict get $dispatchrecord raw] {*}$extraflags] - set commandline [concat $command [dict get $dispatchrecord raw] $extraflags] - } - shell { - do_debug 1 $debugc "DISPATCHING with shell args : $command [dict get $dispatchrecord raw]" - #assume the shell arguments are in one quoted string? - set commandline [concat $command [list [dict get $dispatchrecord raw]] $extraflags] - } - default { - #non quoted shell? raw + defaults? - do_debug 1 $debugc "DISPATCHING with given arg order: $command $matched_in_order $extraflags" - #set commandline [list $command {*}$matched_in_order {*}$extraflags] - set commandline [concat $command $matched_in_order $extraflags] - } - } - - dict set dispatchrecord asdispatched $commandline - set dispatchresult "" - set dispatcherror "" - if {![catch {{*}$commandline} cmdresult]} { - set dispatchresult $cmdresult - lappend dispatchstatuslist [list status ok cmd $parentname outputlength [string length $cmdresult]] - lappend dispatchresultlist $cmdresult - } else { - set dispatchstatus "error" - set dispatcherror $cmdresult - #don't add to dispatchresultlist - lappend dispatchstatuslist [list status err cmd $parentname outputlength 0 error $cmdresult] - if {!$was_dispatched_by_another} { - #this is the first (or a direct) call to check_flags - so make sure error gets raised in this proc rather than just storing the error in the data and returning - set raise_dispatch_error_instead_of_return "dispatchstatuslist:\n[join $dispatchstatuslist \n] \nerrinfo:\n $::errorInfo" - dict set dispatchrecord result $dispatchresult - dict set dispatchrecord error $dispatcherror - dict set dispatch $parentname $dispatchrecord - - break - #return -code error "check_flags error during command dispatch:\n$cmdresult" - } - #we've been dispatched from another check_flags - so ok to propagate the error up via the dispatchrecord/dispatchstatuslist - } - dict set dispatchrecord result $dispatchresult - dict set dispatchrecord error $dispatcherror - dict set dispatch $parentname $dispatchrecord - } - - set dict_dispatch_results [list dispatchcaller $caller dispatchstatuslist $dispatchstatuslist dispatchresultlist $dispatchresultlist dispatchstatus $dispatchstatus] - } - #end llength $dispatch - - - set combined [dict merge $dict_defaults $dict_supplied $processed_arguments $dict_ranges $dict_rangesbytype $dict_dispatch_results] - dict set combined dispatch $dispatch ;#update with asdispatched info - if {([dict get $combined parsestatus] eq "ok") && ([dict get $combined dispatchstatus] eq "ok")} { - dict set combined status "ok" - } else { - dict set combined status "error" - } - do_debug 1 $debugc "COMBINED:$combined" - - - set returnkey [string tolower $returnkey] - if {"all" in $returnkey} { - set returnval $combined - #set returnval [dict merge $combined $dict_dispatch_results] - } else { - if {[llength $returnkey] == 1} { - set invalid 0 - #todo - support multiple merge? - set right "" - if {[regexp -all {\|} $returnkey] == 1} { - lassign [split $returnkey |] left right - set joinparts [split $left ,] - } else { - set joinparts [split $returnkey ,] - } - foreach j [concat $joinparts $right] { - if {$j ni $flaginfo_returns} { - set invalid 1 - } - } - set returnval [list] - if {!$invalid} { - foreach j $joinparts { - lappend returnval {*}[dict get $combined $j] - } - if {[string length $right]} { - set returnval [dict merge $returnval $defaults $returnval] - } - } else { - set returnval [list callerrors [list "-return '$returnkey' not valid"]] - } - } else { - set callerrors [list] - set returnval [dict create] - foreach rk $returnkey { - if {$returnkey in $flaginfo_returns} { - dict set returnval $rk [dict get $combined $returnkey] - } else { - lappend callerrors [list "-return '$returnkey' not valid"] - } - } - if {[llength $callerrors]} { - dict set returnval callerrors $callerrors - } - } - } - - do_debug 1 $debugc "[string repeat = 40]" - do_debug 1 $debugc "dispatch_results: $dict_dispatch_results" - do_debug 1 $debugc "[string repeat - 40]" - - if {[string length $raise_dispatch_error_instead_of_return]} { - set errdebug [dict get $cf_args -debugargsonerror] - if {$errdebug > [dict get $cf_args -debugargs]} { - dict set debugc -debugargs $errdebug - } - } - - set debuglevel_return 2 - set debugdict [concat {*}[lmap k [dict keys $combined] {list $k $debuglevel_return}]] ;#create a dict of keys from combined, all defaulted to $debuglevel_return - if {[llength [dict get $combined parseerrors]]} { - dict set debugdict "parseerrors" 0 - } else { - dict set debugdict "parseerrors" 2 - } - dict set debugdict "defaults" 1 - dict set debugdict "supplied" 1 - dict set debugdict "dispatch" 1 - dict set debugdict "ranges" 1 - dict set debugdict "rangesbytype" 1 - dict set debugdict "dispatchstatus" 1 - if {[dict get $combined "status"] eq "ok"} { - dict set debugdict "status" 1 - } else { - dict set debugdict "status" 0 - } - - do_debug 1 $debugc "returning '$returnkey'" - do_debug 1 $debugc "returnval '$returnval'" - if {([llength $returnval] % 2) == 0} { - do_debug 1 $debugc "returnkeys '[dict keys $returnval]'" - } - do_debug 1 $debugc "[string repeat = 40]" - dict for {k v} $combined { - set dlev [dict get $debugdict $k] - switch -- $k { - dispatch { - set col1 [string repeat " " 12] - #process as paired list rather than dict (support repeated commands) - set i 0 - foreach {cmdname cmdinfo} $v { - set field1 [string repeat " " [expr {[string length $cmdname]}]] - set col2_dispatch [string repeat " " [expr {[string length $cmdname] + 15}]] - set j 0 - foreach {ckey cval} $cmdinfo { - - if {$i == 0 && $j == 0} { - set c1 [overtype::left $col1 "dispatch"] - } else { - set c1 [overtype::left $col1 { ... }] - } - - if {$j == 0} { - set f1 [overtype::left $field1 $cmdname] - set c2 [overtype::left $col2_dispatch "$f1 $ckey"] - } else { - set f1 [overtype::left $field1 ...] - set c2 [overtype::left $col2_dispatch "$f1 $ckey"] - } - #leave at debug level 1 - because dispatch is generally important - do_debug $dlev $debugc "${c1}${c2} $cval" - - incr j - } - incr i - } - - #do_debug 1 $debugc "[overtype::left $col1 $k] [lindex $v 0] [list [lindex $v 1]]" - #foreach {nm rem} [lrange $v 2 end] { - # do_debug 1 $debugc "[overtype::left $col1 { ... }] $nm [list $rem]" - #} - } - dispatchresultlist { - set col1 [string repeat " " 25] - set i 0 - foreach dresult $v { - if {$i == 0} { - set c1 [overtype::left $col1 $k] - } else { - set c1 [overtype::left $col1 { ... }] - } - do_debug $dlev $debugc "$c1 $dresult" - incr i - } - } - classifications { - set col1 [string repeat " " 25] - set len [dict size $v] - if {$len == 0} { - do_debug $dlev $debugc "[overtype::left $col1 $k]" - continue - } - set max [expr {$len -1}] - set numlines [expr $len / 3 + 1] - if {($len % 3) == 0} { - incr numlines -1 - } - set j 0 - for {set ln 0} {$ln < $numlines} {incr ln} { - if {$ln == 0} { - set c1 "[overtype::left $col1 $k]" - } else { - set c1 "[overtype::left $col1 { ... }]" - } - set line "" - for {set col 0} {$col < 3} {incr col} { - if {$j <= $max} { - append line "$j [list [dict get $v $j]] " - } - incr j - } - do_debug $dlev $debugc "$c1 [string trim $line]" - } - } - gridstring { - set col1 [string repeat " " 25] - set i 0 - foreach ln [split $v \n] { - if {$i == 0} { - set c1 [overtype::left $col1 $k] - } else { - set c1 [overtype::left $col1 { ... }] - } - do_debug $dlev $debugc "$c1 $ln" - incr i - } - } - default { - set col1 [string repeat " " 25] - do_debug $dlev $debugc "[overtype::left $col1 $k] $v" - } - } - } - - - # --------------------------------- - foreach obj [$PARENTS items] { - catch {$obj destroy} - } - $PARENTS destroy - #puts "PROCESSORS: $PROCESSORS" - foreach obj [$PROCESSORS items] { - catch {$obj destroy} - } - $PROCESSORS destroy - catch {$RETURNED_VMAP destroy} - # --------------------------------- - - do_debug 1 $debugc "[string repeat = 40]" - do_debug 1 $debugc "DEBUG-END $caller" - if {[string length $raise_dispatch_error_instead_of_return]} { - return -code error $raise_dispatch_error_instead_of_return - } - - - return $returnval - } - - proc tailflagspaired {defaults supplied classifications rangesbytype} { - lassign [lindex $rangesbytype end] c tp a b - if {($c eq "unallocated") && ($tp eq "flagtype")} { - set tail_unallocated [lrange $supplied $a $b] - } else { - set tail_unallocated [list] - } - #set extraflags [list] - set extraflags [punk::lib::dict_merge_ordered $defaults $tail_unallocated] - #dict merge based operation can't work if there are solo_flags? - #review - if {[llength $tail_unallocated]} { - for {set i $a} {$i <=$b} {incr i} { - set arginfo [dict get $classifications $i] - lassign $arginfo class ftype v - switch -- $ftype { - flag - flagvalue { - lappend extraflags $v - } - soloflag { - lappend extraflags $v - if {[dict exists $defaults $v]} { - lappend extraflags [dict get $defaults $v] - } else { - lappend extraflags 1 - } - } - } - } - foreach {k v} [dict get $defaults] { - if {$k ni $extraflags} { - lappend extraflags $k $v - } - } - } else { - set extraflags $defaults - } - return $extraflags - } - - proc tailflagspaired1 {defaults supplied classifications rangesbytype} { - lassign [lindex $rangesbytype end] c tp a b - if {($c eq "unallocated") && ($tp eq "flagtype")} { - set tail_unallocated [lrange $supplied $a $b] - } else { - set tail_unallocated [list] - } - #set all_post_unallocated_ranges [lsearch -all -inline -index 0 [lrange $rangesbytype $command_range_posn end] "unallocated"] - - set extraflags [list] - - #set extraflags [punk::lib::dict_merge_ordered $defaults $tail_unallocated] - #dict merge based operation can't work if there are solo_flags with no value set - if {[llength $tail_unallocated]} { - for {set i $a} {$i <=$b} {incr i} { - set arginfo [dict get $classifications $i] - lassign $arginfo class ftype v - switch -- $ftype { - flag - flagvalue { - lappend extraflags $v - } - soloflag { - lappend extraflags $v - if {[dict exists $defaults $v]} { - lappend extraflags [dict get $defaults $v] - } else { - lappend extraflags 1 - } - } - } - } - foreach {k v} [dict get $defaults] { - if {$k ni $extraflags} { - lappend extraflags $k $v - } - } - } else { - set extraflags $defaults - } - - } - - - -} - - -namespace eval flagfilter { - - #punk::lib::dict_merge_ordered - - - - #retrieve *only* names that are dependant on the provided namekey - not the key itself - # (query is sorted by the trailing numerical index which represents order the arguments were processed) - proc flag_array_get_sorted_subs {arrname sep namekey} { - upvar $arrname arr - set allsubs [array names arr ${namekey}.*${sep}name,*] - set rnames [lmap nm $allsubs {string reverse $nm}] - set sorted_rnames [lsort -dictionary $rnames] - set ordered [lmap nm $sorted_rnames {string reverse $nm}] - return $ordered - } - - proc flag_array_get_sorted_siblings {arrname sep namekey} { - #determine parent by looking at dot - but confirm parent name is in array. - - } - - - - #dictionary based lsort of reversed names which are presumed to have a trailing separator of some sort and a number e.g: name,0 name,1 ... name,10 etc. - #use -dictionary to ensure embedded numbers are sorted as integers - proc array_names_sorted_by_tail {arrname nameglob} { - upvar $arrname arr - set matched_names [array names arr $nameglob] - set rnames [lmap nm $matched_names {string reverse $nm}] - set sorted_rnames [lsort -dictionary $rnames] - return [lmap nm $sorted_rnames {string reverse $nm}] - } - - -} - - - - - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/funcl-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/funcl-0.1.tm deleted file mode 100644 index e8430fb0..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/funcl-0.1.tm +++ /dev/null @@ -1,325 +0,0 @@ -package provide funcl [namespace eval funcl { - variable version - set version 0.1 -}] -#funcl = function list (nested call structure) -# -#a basic functional composition o combinator -#o(f,g)(x) == f(g(x)) - -namespace eval funcl { - - #from punk::pipe - proc arg_is_script_shaped {arg} { - if {[string first " " $arg] >= 0} { - return 1 - } elseif {[string first \n $arg] >= 0} { - return 1 - } elseif {[string first ";" $arg] >= 0} { - return 1 - } elseif {[string first \t $arg] >= 0} { - return 1 - } else { - return 0 - } - } - - - proc o args { - set closing [string repeat {]} [expr [llength $args]-1]] - set body "[join $args { [}] \$data $closing" - return $body - } - - proc o_ args { - set body "" - set tails [lrepeat [llength $args] ""] - puts stdout "tails: $tails" - - set end [lindex $args end] - if {[llength $end] == 1 && [arg_is_script_shaped $end]} { - set endfunc [string map " $end" {uplevel 1 [list if 1 ]}] - } else { - set endfunc $end - } - if {[llength $args] == 1} { - return $endfunc - } - - set wrap { [} - append wrap $endfunc - append wrap { ]} - - set i 0 - foreach cmdlist [lrange $args 0 end-1] { - set is_script 0 - if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { - set is_script 1 - set script [lindex $cmdlist 0] - } - set t "" - if {$i > 0} { - append body { [} - } - set posn [lsearch $cmdlist _] - if {$posn <= 0} { - append body $cmdlist - if {$i == ([llength $args]-2)} { - append body " $wrap" - } - #if {$i == [expr {[llength $args] -2}]} { - # #append body " \$data" - # append body " $wrap" - #} - if {$i > 0} { - set t {]} - } - } else { - append body [lrange $cmdlist 0 $posn-1] - if {$i == ([llength $args] -2)} { - #append body " \$data" - append body " $wrap" - } - set t [lrange $cmdlist $posn+1 end] - if {$i > 0} { - append t { ]} - } - } - lset tails $i $t - incr i - } - append body [join [lreverse $tails] " "] - puts stdout "tails: $tails" - - return $body - } - - #review - consider _call -- if count > 1 then they must all be callable cmdlists(?) - # what does it mean to have additional _fn wrapper with no other elements? (no actual function) - #e.g _fn 2 5 6 somefunc {_fn 1 3 {_call 1 3 xxx}} {_fn 1 4 command {_fn ...}} - # what type indicates running subtrees in parallel vs sequentially? - # any reason to have _call count other than 1? Presumably the parent node indicates the parallelism/sequentialism etc. - # - # - # accept or return a funcl (or funcltree if multiple funcls in one commandlist) - # also accept/return a call - return empty list if passed a call - proc next_funcl {funcl_or_tree} { - if {[lindex $funcl_or_tree 0] eq "_call"} { - return [list] - } - if {[lindex $funcl_or_tree 0] in [list "_fn" "_call"]} { - set funcl $funcl_or_tree - } else { - error "funcltree not implemented" - } - - - set count [lindex $funcl 1] - if {$count == 0} { - #null funcl.. what is it? metadata/placeholder? - return $funcl - } - set indices [lrange $funcl 2 [expr {1 + $count}]] - set i 0 - foreach idx $indices { - if {$i > 0} { - #todo - return a funcltree - error "multi funcl not implemented" - } - set next [lindex $funcl $idx] - incr i - } - - return $next - - } - - #convert a funcl to a tcl script - proc funcl_script {funcl} { - if {![llength $funcl]} { - return "" - } - set body "" - set tails [list] - - set type [lindex $funcl 0] - if {$type ni [list "_fn" "_call"]} { - #todo - handle funcltree - error "type $type not implemented" - } - - - #only count of 1 with index 3 supported(?) - if {$type eq "_call"} { - #leaf - set cmdlist [lindex $funcl 3] - return $cmdlist - } - - #we will use next_funcl to walk the nodes.. todo support treefuncl response from next_funcl which could branch multiple times. - #by continually passing back the resulting treefuncl/funcl to next_funcl we can process in correct order (?) - # we would still need to maintain state to stitch it back together once returned from a subtree.. - # ie multiple tail parts - set count [lindex $funcl 1] - - if {$count == 1} { - set idx [lindex $funcl 2] - if {$idx == 3} { - set cmdlist_pre [list] - } else { - set cmdlist_pre [lrange $funcl 3 $idx-1] - } - append body $cmdlist_pre - set t [lrange $funcl $idx+1 end] - lappend tails $t - } else { - #?? - error "funcl_script branching not yet supported" - } - - - set get_next 1 - set i 1 - while {$get_next} { - set funcl [next_funcl $funcl] - if {![llength $funcl]} { - set get_next 0 - } - lassign $funcl type count idx ;#todo support count > 1 - if {$type eq "_call"} { - set get_next 0 - } - set t "" - if {$type eq "_call"} { - append body { [} - append body [lindex $funcl $idx] - append body { ]} - } else { - append body { [} - if {$idx == 3} { - set cmdlist_pre [list] - } else { - set cmdlist_pre [lrange $funcl 3 $idx-1] - } - append body $cmdlist_pre - set t [lrange $funcl $idx+1 end] - lappend tails $t - lappend tails { ]} - } - incr i - } - append body [join [lreverse $tails] " "] - #puts stdout "tails: $tails" - - return $body - } - - - interp alias "" o_of "" funcl::o_of_n 1 - - #o_of_n - #tcl list rep o combinator - # - # can take lists of ordinary commandlists, scripts and funcls - # _fn 1 x where 1 indicates number of subfuncls and where x indicates next funcl position (_fn list or _arg) - # _fn 0 indicates next item is an unwrapped commandlist (terminal command) - # - #o_of is equivalent to o_of_n 1 (1 argument o combinator) - #last n args are passed to the prior function - #e.g for n=1 f a b = f(a(b)) - #e.g for n=2, e f a b = e(f(a b)) - proc o_of_n {n args} { - puts stdout "o_of_n '$args'" - if {$n != 1} { - error "o_of_n only implemented for 1 sub-funcl" - } - set comp [list] ;#composition list - set end [lindex $args end] - if {[lindex $end 0] in {_fn _call}]} { - #is_funcl - set endfunc [lindex $args end] - } else { - if {[llength $end] == 1 && [arg_is_script_shaped $end]} { - #set endfunc [string map [list $end] {uplevel 1 [list if 1 ]}] - set endfunc [list _call 1 3 [list uplevel 1 [list if 1 [lindex $end 0]]]] - } else { - set endfunc [list _call 1 3 [list {*}$end]] - } - } - - if {[llength $args] == 1} { - return $endfunc - } - set comp $endfunc - set revlist [lreverse [lrange $args 0 end-1]] - foreach cmdlist $revlist { - puts stderr "o_of_n >>-- $cmdlist" - if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { - set is_script 1 - set script [lindex $cmdlist 0] - set arglist [list data] - - set comp [list _fn 1 6 call_script $script $arglist $comp] - } else { - set posn1 [expr {[llength $cmdlist] + 2 + $n}] - set comp [list _fn $n $posn1 {*}$cmdlist $comp] - } - } - return $comp - } - proc call_script {script argnames args} { - uplevel 3 [list if 1 [list apply [list $argnames $script] {*}$args]] - } - proc funcl_script_test {scr} { - do_funcl_script_test $scr - } - proc do_funcl_script_test {scr} { - #set j "in do_funcl_script_test" - #set data "xxx" - #puts '$scr' - if 1 $scr - } - - #standard o_ with no script-handling - proc o_plain args { - set body "" - set i 0 - set tails [lrepeat [llength $args] ""] - #puts stdout "tails: $tails" - foreach cmdlist $args { - set t "" - if {$i > 0} { - append body { [} - } - set posn [lsearch $cmdlist _] - if {$posn <= 0} { - append body $cmdlist - if {$i == ([llength $args] -1)} { - append body " \$data" - } - if {$i > 0} { - set t {]} - } - } else { - append body [lrange $cmdlist 0 $posn-1] - if {$i == ([llength $args] -1)} { - append body " \$data" - } - set t [lrange $cmdlist $posn+1 end] - if {$i > 0} { - append t { ]} - } - } - lset tails $i $t - incr i - } - append body [join [lreverse $tails] " "] - #puts stdout "tails: $tails" - - return $body - } - #timings suggest no faster to split out the first item from the cmdlist loop -} - - - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/http-2.10b1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/http-2.10b1.tm deleted file mode 100644 index 6c3c068c..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/http-2.10b1.tm +++ /dev/null @@ -1,5457 +0,0 @@ -# http.tcl -- -# -# Client-side HTTP for GET, POST, and HEAD commands. These routines can -# be used in untrusted code that uses the Safesock security policy. -# These procedures use a callback interface to avoid using vwait, which -# is not defined in the safe base. -# -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. - -package require Tcl 8.6- -# Keep this in sync with pkgIndex.tcl and with the install directories in -# Makefiles -package provide http 2.10b1 - -namespace eval http { - # Allow resourcing to not clobber existing data - - variable http - if {![info exists http]} { - array set http { - -accept */* - -cookiejar {} - -pipeline 1 - -postfresh 0 - -proxyhost {} - -proxyport {} - -proxyfilter http::ProxyRequired - -proxynot {} - -proxyauth {} - -repost 0 - -threadlevel 0 - -urlencoding utf-8 - -zip 1 - } - # We need a useragent string of this style or various servers will - # refuse to send us compressed content even when we ask for it. This - # follows the de-facto layout of user-agent strings in current browsers. - # Safe interpreters do not have ::tcl_platform(os) or - # ::tcl_platform(osVersion). - if {[interp issafe]} { - set http(-useragent) "Mozilla/5.0\ - (Windows; U;\ - Windows NT 10.0)\ - http/[package provide http] Tcl/[package provide Tcl]" - } else { - set http(-useragent) "Mozilla/5.0\ - ([string totitle $::tcl_platform(platform)]; U;\ - $::tcl_platform(os) $::tcl_platform(osVersion))\ - http/[package provide http] Tcl/[package provide Tcl]" - } - } - - proc init {} { - # Set up the map for quoting chars. RFC3986 Section 2.3 say percent - # encode all except: "... percent-encoded octets in the ranges of - # ALPHA (%41-%5A and %61-%7A), DIGIT (%30-%39), hyphen (%2D), period - # (%2E), underscore (%5F), or tilde (%7E) should not be created by URI - # producers ..." - for {set i 0} {$i <= 256} {incr i} { - set c [format %c $i] - if {![string match {[-._~a-zA-Z0-9]} $c]} { - set map($c) %[format %.2X $i] - } - } - # These are handled specially - set map(\n) %0D%0A - variable formMap [array get map] - - # Create a map for HTTP/1.1 open sockets - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - if {[info exists socketMapping]} { - # Close open sockets on re-init. Do not permit retries. - foreach {url sock} [array get socketMapping] { - unset -nocomplain socketClosing($url) - unset -nocomplain socketPlayCmd($url) - CloseSocket $sock - } - } - - # CloseSocket should have unset the socket* arrays, one element at - # a time. Now unset anything that was overlooked. - # Traces on "unset socketRdState(*)" will call CancelReadPipeline and - # cancel any queued responses. - # Traces on "unset socketWrState(*)" will call CancelWritePipeline and - # cancel any queued requests. - array unset socketMapping - array unset socketRdState - array unset socketWrState - array unset socketRdQueue - array unset socketWrQueue - array unset socketPhQueue - array unset socketClosing - array unset socketPlayCmd - array unset socketCoEvent - array unset socketProxyId - array set socketMapping {} - array set socketRdState {} - array set socketWrState {} - array set socketRdQueue {} - array set socketWrQueue {} - array set socketPhQueue {} - array set socketClosing {} - array set socketPlayCmd {} - array set socketCoEvent {} - array set socketProxyId {} - return - } - init - - variable urlTypes - if {![info exists urlTypes]} { - set urlTypes(http) [list 80 ::http::socket] - } - - variable encodings [string tolower [encoding names]] - # This can be changed, but iso8859-1 is the RFC standard. - variable defaultCharset - if {![info exists defaultCharset]} { - set defaultCharset "iso8859-1" - } - - # Force RFC 3986 strictness in geturl url verification? - variable strict - if {![info exists strict]} { - set strict 1 - } - - # Let user control default keepalive for compatibility - variable defaultKeepalive - if {![info exists defaultKeepalive]} { - set defaultKeepalive 0 - } - - # Regular expression used to parse cookies - variable CookieRE {(?x) # EXPANDED SYNTAX - \s* # Ignore leading spaces - ([^][\u0000- ()<>@,;:\\""/?={}\u007f-\uffff]+) # Match the name - = # LITERAL: Equal sign - ([!\u0023-+\u002D-:<-\u005B\u005D-~]*) # Match the value - (?: - \s* ; \s* # LITERAL: semicolon - ([^\u0000]+) # Match the options - )? - } - - variable TmpSockCounter 0 - variable ThreadCounter 0 - - variable reasonDict [dict create {*}{ - 100 Continue - 101 {Switching Protocols} - 102 Processing - 103 {Early Hints} - 200 OK - 201 Created - 202 Accepted - 203 {Non-Authoritative Information} - 204 {No Content} - 205 {Reset Content} - 206 {Partial Content} - 207 Multi-Status - 208 {Already Reported} - 226 {IM Used} - 300 {Multiple Choices} - 301 {Moved Permanently} - 302 Found - 303 {See Other} - 304 {Not Modified} - 305 {Use Proxy} - 306 (Unused) - 307 {Temporary Redirect} - 308 {Permanent Redirect} - 400 {Bad Request} - 401 Unauthorized - 402 {Payment Required} - 403 Forbidden - 404 {Not Found} - 405 {Method Not Allowed} - 406 {Not Acceptable} - 407 {Proxy Authentication Required} - 408 {Request Timeout} - 409 Conflict - 410 Gone - 411 {Length Required} - 412 {Precondition Failed} - 413 {Content Too Large} - 414 {URI Too Long} - 415 {Unsupported Media Type} - 416 {Range Not Satisfiable} - 417 {Expectation Failed} - 418 (Unused) - 421 {Misdirected Request} - 422 {Unprocessable Content} - 423 Locked - 424 {Failed Dependency} - 425 {Too Early} - 426 {Upgrade Required} - 428 {Precondition Required} - 429 {Too Many Requests} - 431 {Request Header Fields Too Large} - 451 {Unavailable For Legal Reasons} - 500 {Internal Server Error} - 501 {Not Implemented} - 502 {Bad Gateway} - 503 {Service Unavailable} - 504 {Gateway Timeout} - 505 {HTTP Version Not Supported} - 506 {Variant Also Negotiates} - 507 {Insufficient Storage} - 508 {Loop Detected} - 510 {Not Extended (OBSOLETED)} - 511 {Network Authentication Required} - }] - - variable failedProxyValues { - binary - body - charset - coding - connection - connectionRespFlag - currentsize - host - http - httpResponse - meta - method - querylength - queryoffset - reasonPhrase - requestHeaders - requestLine - responseCode - state - status - tid - totalsize - transfer - type - } - - namespace export geturl config reset wait formatQuery postError quoteString - namespace export register unregister registerError - namespace export requestLine requestHeaders requestHeaderValue - namespace export responseLine responseHeaders responseHeaderValue - namespace export responseCode responseBody responseInfo reasonPhrase - # - Legacy aliases, were never exported: - # data, code, mapReply, meta, ncode - # - Callable from outside (e.g. from TLS) by fully-qualified name, but - # not exported: - # socket - # - Useful, but never exported (and likely to have naming collisions): - # size, status, cleanup, error, init - # Comments suggest that "init" can be used for re-initialisation, - # although the command is undocumented. - # - Never exported, renamed from lower-case names: - # GetTextLine, MakeTransformationChunked. -} - -# http::Log -- -# -# Debugging output -- define this to observe HTTP/1.1 socket usage. -# Should echo any args received. -# -# Arguments: -# msg Message to output -# -if {[info command http::Log] eq {}} {proc http::Log {args} {}} - -# http::register -- -# -# See documentation for details. -# -# Arguments: -# proto URL protocol prefix, e.g. https -# port Default port for protocol -# command Command to use to create socket -# Results: -# list of port and command that was registered. - -proc http::register {proto port command} { - variable urlTypes - set urlTypes([string tolower $proto]) [list $port $command] -} - -# http::unregister -- -# -# Unregisters URL protocol handler -# -# Arguments: -# proto URL protocol prefix, e.g. https -# Results: -# list of port and command that was unregistered. - -proc http::unregister {proto} { - variable urlTypes - set lower [string tolower $proto] - if {![info exists urlTypes($lower)]} { - return -code error "unsupported url type \"$proto\"" - } - set old $urlTypes($lower) - unset urlTypes($lower) - return $old -} - -# http::config -- -# -# See documentation for details. -# -# Arguments: -# args Options parsed by the procedure. -# Results: -# TODO - -proc http::config {args} { - variable http - set options [lsort [array names http -*]] - set usage [join $options ", "] - if {[llength $args] == 0} { - set result {} - foreach name $options { - lappend result $name $http($name) - } - return $result - } - set options [string map {- ""} $options] - set pat ^-(?:[join $options |])$ - if {[llength $args] == 1} { - set flag [lindex $args 0] - if {![regexp -- $pat $flag]} { - return -code error "Unknown option $flag, must be: $usage" - } - return $http($flag) - } elseif {[llength $args] % 2} { - return -code error "If more than one argument is supplied, the\ - number of arguments must be even" - } else { - foreach {flag value} $args { - if {![regexp -- $pat $flag]} { - return -code error "Unknown option $flag, must be: $usage" - } - if {($flag eq {-threadlevel}) && ($value ni {0 1 2})} { - return -code error {Option -threadlevel must be 0, 1 or 2} - } - set http($flag) $value - } - return - } -} - -# ------------------------------------------------------------------------------ -# Proc http::reasonPhrase -# ------------------------------------------------------------------------------ -# Command to return the IANA-recommended "reason phrase" for a HTTP Status Code. -# Information obtained from: -# https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml -# -# Arguments: -# code - A valid HTTP Status Code (integer from 100 to 599) -# -# Return Value: the reason phrase -# ------------------------------------------------------------------------------ - -proc http::reasonPhrase {code} { - variable reasonDict - if {![regexp -- {^[1-5][0-9][0-9]$} $code]} { - set msg {argument must be a three-digit integer from 100 to 599} - return -code error $msg - } - if {[dict exists $reasonDict $code]} { - set reason [dict get $reasonDict $code] - } else { - set reason Unassigned - } - return $reason -} - -# http::Finish -- -# -# Clean up the socket and eval close time callbacks -# -# Arguments: -# token Connection token. -# errormsg (optional) If set, forces status to error. -# skipCB (optional) If set, don't call the -command callback. This -# is useful when geturl wants to throw an exception instead -# of calling the callback. That way, the same error isn't -# reported to two places. -# -# Side Effects: -# May close the socket. - -proc http::Finish {token {errormsg ""} {skipCB 0}} { - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - variable $token - upvar 0 $token state - global errorInfo errorCode - set closeQueue 0 - if {$errormsg ne ""} { - set state(error) [list $errormsg $errorInfo $errorCode] - set state(status) "error" - } - if {[info commands ${token}--EventCoroutine] ne {}} { - rename ${token}--EventCoroutine {} - } - if {[info commands ${token}--SocketCoroutine] ne {}} { - rename ${token}--SocketCoroutine {} - } - if {[info exists state(socketcoro)]} { - Log $token Cancel socket after-idle event (Finish) - after cancel $state(socketcoro) - unset state(socketcoro) - } - - # Is this an upgrade request/response? - set upgradeResponse \ - [expr { [info exists state(upgradeRequest)] - && $state(upgradeRequest) - && [info exists state(http)] - && ([ncode $token] eq {101}) - && [info exists state(connection)] - && ("upgrade" in $state(connection)) - && [info exists state(upgrade)] - && ("" ne $state(upgrade)) - }] - - if { ($state(status) eq "timeout") - || ($state(status) eq "error") - || ($state(status) eq "eof") - } { - set closeQueue 1 - set connId $state(socketinfo) - if {[info exists state(sock)]} { - set sock $state(sock) - CloseSocket $state(sock) $token - } else { - # When opening the socket and calling http::reset - # immediately, the socket may not yet exist. - # Test http-4.11 may come here. - } - if {$state(tid) ne {}} { - # When opening the socket in a thread, and calling http::reset - # immediately, the thread may still exist. - # Test http-4.11 may come here. - thread::release $state(tid) - set state(tid) {} - } else { - } - } elseif {$upgradeResponse} { - # Special handling for an upgrade request/response. - # - geturl ensures that this is not a "persistent" socket used for - # multiple HTTP requests, so a call to KeepSocket is not needed. - # - Leave socket open, so a call to CloseSocket is not needed either. - # - Remove fileevent bindings. The caller will set its own bindings. - # - THE CALLER MUST PROCESS THE UPGRADED SOCKET IN THE CALLBACK COMMAND - # PASSED TO http::geturl AS -command callback. - catch {fileevent $state(sock) readable {}} - catch {fileevent $state(sock) writable {}} - } elseif { - ([info exists state(-keepalive)] && !$state(-keepalive)) - || ([info exists state(connection)] && ("close" in $state(connection))) - } { - set closeQueue 1 - set connId $state(socketinfo) - if {[info exists state(sock)]} { - set sock $state(sock) - CloseSocket $state(sock) $token - } else { - # When opening the socket and calling http::reset - # immediately, the socket may not yet exist. - # Test http-4.11 may come here. - } - } elseif { - ([info exists state(-keepalive)] && $state(-keepalive)) - && ([info exists state(connection)] && ("close" ni $state(connection))) - } { - KeepSocket $token - } - if {[info exists state(after)]} { - after cancel $state(after) - unset state(after) - } - if {[info exists state(-command)] && (!$skipCB) - && (![info exists state(done-command-cb)])} { - set state(done-command-cb) yes - if { [catch {namespace eval :: $state(-command) $token} err] - && ($errormsg eq "") - } { - set state(error) [list $err $errorInfo $errorCode] - set state(status) error - } - } - - if { $closeQueue - && [info exists socketMapping($connId)] - && ($socketMapping($connId) eq $sock) - } { - http::CloseQueuedQueries $connId $token - # This calls Unset. Other cases do not need the call. - } - return -} - -# http::KeepSocket - -# -# Keep a socket in the persistent sockets table and connect it to its next -# queued task if possible. Otherwise leave it idle and ready for its next -# use. -# -# If $socketClosing(*), then ("close" in $state(connection)) and therefore -# this command will not be called by Finish. -# -# Arguments: -# token Connection token. - -proc http::KeepSocket {token} { - variable http - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - variable $token - upvar 0 $token state - set tk [namespace tail $token] - - # Keep this socket open for another request ("Keep-Alive"). - # React if the server half-closes the socket. - # Discussion is in http::geturl. - catch {fileevent $state(sock) readable [list http::CheckEof $state(sock)]} - - # The line below should not be changed in production code. - # It is edited by the test suite. - set TEST_EOF 0 - if {$TEST_EOF} { - # ONLY for testing reaction to server eof. - # No server timeouts will be caught. - catch {fileevent $state(sock) readable {}} - } - - if { [info exists state(socketinfo)] - && [info exists socketMapping($state(socketinfo))] - } { - set connId $state(socketinfo) - # The value "Rready" is set only here. - set socketRdState($connId) Rready - - if { $state(-pipeline) - && [info exists socketRdQueue($connId)] - && [llength $socketRdQueue($connId)] - } { - # The usual case for pipelined responses - if another response is - # queued, arrange to read it. - set token3 [lindex $socketRdQueue($connId) 0] - set socketRdQueue($connId) [lrange $socketRdQueue($connId) 1 end] - - #Log pipelined, GRANT read access to $token3 in KeepSocket - set socketRdState($connId) $token3 - ReceiveResponse $token3 - - # Other pipelined cases. - # - The test above ensures that, for the pipelined cases in the two - # tests below, the read queue is empty. - # - In those two tests, check whether the next write will be - # nonpipeline. - } elseif { - $state(-pipeline) - && [info exists socketWrState($connId)] - && ($socketWrState($connId) eq "peNding") - - && [info exists socketWrQueue($connId)] - && [llength $socketWrQueue($connId)] - && (![set token3 [lindex $socketWrQueue($connId) 0] - set ${token3}(-pipeline) - ] - ) - } { - # This case: - # - Now it the time to run the "pending" request. - # - The next token in the write queue is nonpipeline, and - # socketWrState has been marked "pending" (in - # http::NextPipelinedWrite or http::geturl) so a new pipelined - # request cannot jump the queue. - # - # Tests: - # - In this case the read queue (tested above) is empty and this - # "pending" write token is in front of the rest of the write - # queue. - # - The write state is not Wready and therefore appears to be busy, - # but because it is "pending" we know that it is reserved for the - # first item in the write queue, a non-pipelined request that is - # waiting for the read queue to empty. That has now happened: so - # give that request read and write access. - set conn [set ${token3}(connArgs)] - #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket - set socketRdState($connId) $token3 - set socketWrState($connId) $token3 - set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] - # Connect does its own fconfigure. - fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] - #Log ---- $state(sock) << conn to $token3 for HTTP request (c) - - } elseif { - $state(-pipeline) - && [info exists socketWrState($connId)] - && ($socketWrState($connId) eq "peNding") - - } { - # Should not come here. The second block in the previous "elseif" - # test should be tautologous (but was needed in an earlier - # implementation) and will be removed after testing. - # If we get here, the value "pending" was assigned in error. - # This error would block the queue for ever. - Log ^X$tk <<<<< Error in queueing of requests >>>>> - token $token - - } elseif { - $state(-pipeline) - && [info exists socketWrState($connId)] - && ($socketWrState($connId) eq "Wready") - - && [info exists socketWrQueue($connId)] - && [llength $socketWrQueue($connId)] - && (![set token3 [lindex $socketWrQueue($connId) 0] - set ${token3}(-pipeline) - ] - ) - } { - # This case: - # - The next token in the write queue is nonpipeline, and - # socketWrState is Wready. Get the next event from socketWrQueue. - # Tests: - # - In this case the read state (tested above) is Rready and the - # write state (tested here) is Wready - there is no "pending" - # request. - # Code: - # - The code is the same as the code below for the nonpipelined - # case with a queued request. - set conn [set ${token3}(connArgs)] - #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket - set socketRdState($connId) $token3 - set socketWrState($connId) $token3 - set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] - # Connect does its own fconfigure. - fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] - #Log ---- $state(sock) << conn to $token3 for HTTP request (c) - - } elseif { - (!$state(-pipeline)) - && [info exists socketWrQueue($connId)] - && [llength $socketWrQueue($connId)] - && ("close" ni $state(connection)) - } { - # If not pipelined, (socketRdState eq Rready) tells us that we are - # ready for the next write - there is no need to check - # socketWrState. Write the next request, if one is waiting. - # If the next request is pipelined, it receives premature read - # access to the socket. This is not a problem. - set token3 [lindex $socketWrQueue($connId) 0] - set conn [set ${token3}(connArgs)] - #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket - set socketRdState($connId) $token3 - set socketWrState($connId) $token3 - set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] - # Connect does its own fconfigure. - fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] - #Log ---- $state(sock) << conn to $token3 for HTTP request (d) - - } elseif {(!$state(-pipeline))} { - set socketWrState($connId) Wready - # Rready and Wready and idle: nothing to do. - } - - } else { - CloseSocket $state(sock) $token - # There is no socketMapping($state(socketinfo)), so it does not matter - # that CloseQueuedQueries is not called. - } - return -} - -# http::CheckEof - -# -# Read from a socket and close it if eof. -# The command is bound to "fileevent readable" on an idle socket, and -# "eof" is the only event that should trigger the binding, occurring when -# the server times out and half-closes the socket. -# -# A read is necessary so that [eof] gives a meaningful result. -# Any bytes sent are junk (or a bug). - -proc http::CheckEof {sock} { - set junk [read $sock] - set n [string length $junk] - if {$n} { - Log "WARNING: $n bytes received but no HTTP request sent" - } - - if {[catch {eof $sock} res] || $res} { - # The server has half-closed the socket. - # If a new write has started, its transaction will fail and - # will then be error-handled. - CloseSocket $sock - } - return -} - -# http::CloseSocket - -# -# Close a socket and remove it from the persistent sockets table. If -# possible an http token is included here but when we are called from a -# fileevent on remote closure we need to find the correct entry - hence -# the "else" block of the first "if" command. - -proc http::CloseSocket {s {token {}}} { - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - set tk [namespace tail $token] - - catch {fileevent $s readable {}} - set connId {} - if {$token ne ""} { - variable $token - upvar 0 $token state - if {[info exists state(socketinfo)]} { - set connId $state(socketinfo) - } - } else { - set map [array get socketMapping] - set ndx [lsearch -exact $map $s] - if {$ndx >= 0} { - incr ndx -1 - set connId [lindex $map $ndx] - } - } - if { ($connId ne {}) - && [info exists socketMapping($connId)] - && ($socketMapping($connId) eq $s) - } { - Log "Closing connection $connId (sock $socketMapping($connId))" - if {[catch {close $socketMapping($connId)} err]} { - Log "Error closing connection: $err" - } else { - } - if {$token eq {}} { - # Cases with a non-empty token are handled by Finish, so the tokens - # are finished in connection order. - http::CloseQueuedQueries $connId - } else { - } - } else { - Log "Closing socket $s (no connection info)" - if {[catch {close $s} err]} { - Log "Error closing socket: $err" - } else { - } - } - return -} - -# http::CloseQueuedQueries -# -# connId - identifier "domain:port" for the connection -# token - (optional) used only for logging -# -# Called from http::CloseSocket and http::Finish, after a connection is closed, -# to clear the read and write queues if this has not already been done. - -proc http::CloseQueuedQueries {connId {token {}}} { - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - ##Log CloseQueuedQueries $connId $token - if {![info exists socketMapping($connId)]} { - # Command has already been called. - # Don't come here again - especially recursively. - return - } - - # Used only for logging. - if {$token eq {}} { - set tk {} - } else { - set tk [namespace tail $token] - } - - if { [info exists socketPlayCmd($connId)] - && ($socketPlayCmd($connId) ne {ReplayIfClose Wready {} {}}) - } { - # Before unsetting, there is some unfinished business. - # - If the server sent "Connection: close", we have stored the command - # for retrying any queued requests in socketPlayCmd, so copy that - # value for execution below. socketClosing(*) was also set. - # - Also clear the queues to prevent calls to Finish that would set the - # state for the requests that will be retried to "finished with error - # status". - # - At this stage socketPhQueue is empty. - set unfinished $socketPlayCmd($connId) - set socketRdQueue($connId) {} - set socketWrQueue($connId) {} - } else { - set unfinished {} - } - - Unset $connId - - if {$unfinished ne {}} { - Log ^R$tk Any unfinished transactions (excluding $token) failed \ - - token $token - unfinished $unfinished - {*}$unfinished - # Calls ReplayIfClose. - } - return -} - -# http::Unset -# -# The trace on "unset socketRdState(*)" will call CancelReadPipeline -# and cancel any queued responses. -# The trace on "unset socketWrState(*)" will call CancelWritePipeline -# and cancel any queued requests. - -proc http::Unset {connId} { - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - unset socketMapping($connId) - unset socketRdState($connId) - unset socketWrState($connId) - unset -nocomplain socketRdQueue($connId) - unset -nocomplain socketWrQueue($connId) - unset -nocomplain socketClosing($connId) - unset -nocomplain socketPlayCmd($connId) - unset -nocomplain socketProxyId($connId) - return -} - -# http::reset -- -# -# See documentation for details. -# -# Arguments: -# token Connection token. -# why Status info. -# -# Side Effects: -# See Finish - -proc http::reset {token {why reset}} { - variable $token - upvar 0 $token state - set state(status) $why - catch {fileevent $state(sock) readable {}} - catch {fileevent $state(sock) writable {}} - Finish $token - if {[info exists state(error)]} { - set errorlist $state(error) - unset state - eval ::error $errorlist - # i.e. error msg errorInfo errorCode - } - return -} - -# http::geturl -- -# -# Establishes a connection to a remote url via http. -# -# Arguments: -# url The http URL to goget. -# args Option value pairs. Valid options include: -# -blocksize, -validate, -headers, -timeout -# Results: -# Returns a token for this connection. This token is the name of an -# array that the caller should unset to garbage collect the state. - -proc http::geturl {url args} { - variable urlTypes - - # - If ::tls::socketCmd has its default value "::socket", change it to the - # new value ::http::socketForTls. - # - If the old value is different, then it has been modified either by the - # script or by the Tcl installation, and replaced by a new command. The - # script or installation that modified ::tls::socketCmd is also - # responsible for integrating ::http::socketForTls into its own "new" - # command, if it wishes to do so. - # - Commands that open a socket: - # - ::socket - basic - # - ::http::socket - can use a thread to avoid blockage by slow DNS - # lookup. See http::config option -threadlevel. - # - ::http::socketForTls - as ::http::socket, but can also open a socket - # for HTTPS/TLS through a proxy. - - if {[info exists ::tls::socketCmd] && ($::tls::socketCmd eq {::socket})} { - set ::tls::socketCmd ::http::socketForTls - } - - set token [CreateToken $url {*}$args] - variable $token - upvar 0 $token state - - AsyncTransaction $token - - # -------------------------------------------------------------------------- - # Synchronous Call to http::geturl - # -------------------------------------------------------------------------- - # - If the call to http::geturl is asynchronous, it is now complete (apart - # from delivering the return value). - # - If the call to http::geturl is synchronous, the command must now wait - # for the HTTP transaction to be completed. The call to http::wait uses - # vwait, which may be inappropriate if the caller makes other HTTP - # requests in the background. - # -------------------------------------------------------------------------- - - if {![info exists state(-command)]} { - # geturl does EVERYTHING asynchronously, so if the user - # calls it synchronously, we just do a wait here. - http::wait $token - - if {![info exists state]} { - # If we timed out then Finish has been called and the users - # command callback may have cleaned up the token. If so we end up - # here with nothing left to do. - return $token - } elseif {$state(status) eq "error"} { - # Something went wrong while trying to establish the connection. - # Clean up after events and such, but DON'T call the command - # callback (if available) because we're going to throw an - # exception from here instead. - set err [lindex $state(error) 0] - cleanup $token - return -code error $err - } - } - - return $token -} - -# ------------------------------------------------------------------------------ -# Proc http::CreateToken -# ------------------------------------------------------------------------------ -# Command to convert arguments into an initialised request token. -# The return value is the variable name of the token. -# -# Other effects: -# - Sets ::http::http(usingThread) if not already done -# - Sets ::http::http(uid) if not already done -# - Increments ::http::http(uid) -# - May increment ::http::TmpSockCounter -# - Alters ::http::socketPlayCmd, ::http::socketWrQueue if a -keepalive 1 -# request is appended to the queue of a persistent socket that is already -# scheduled to close. -# This also sets state(alreadyQueued) to 1. -# - Alters ::http::socketPhQueue if a -keepalive 1 request is appended to the -# queue of a persistent socket that has not yet been created (and is therefore -# represented by a placeholder). -# This also sets state(ReusingPlaceholder) to 1. -# ------------------------------------------------------------------------------ - -proc http::CreateToken {url args} { - variable http - variable urlTypes - variable defaultCharset - variable defaultKeepalive - variable strict - variable TmpSockCounter - - # Initialize the state variable, an array. We'll return the name of this - # array as the token for the transaction. - - if {![info exists http(usingThread)]} { - set http(usingThread) 0 - } - if {![info exists http(uid)]} { - set http(uid) 0 - } - set token [namespace current]::[incr http(uid)] - ##Log Starting http::geturl - token $token - variable $token - upvar 0 $token state - set tk [namespace tail $token] - reset $token - Log ^A$tk URL $url - token $token - - # Process command options. - - array set state { - -binary false - -blocksize 8192 - -queryblocksize 8192 - -validate 0 - -headers {} - -timeout 0 - -type application/x-www-form-urlencoded - -queryprogress {} - -protocol 1.1 - -guesstype 0 - binary 0 - state created - meta {} - method {} - coding {} - currentsize 0 - totalsize 0 - querylength 0 - queryoffset 0 - type application/octet-stream - body {} - status "" - http "" - httpResponse {} - responseCode {} - reasonPhrase {} - connection keep-alive - tid {} - requestHeaders {} - requestLine {} - transfer {} - proxyUsed none - } - set state(-keepalive) $defaultKeepalive - set state(-strict) $strict - # These flags have their types verified [Bug 811170] - array set type { - -binary boolean - -blocksize integer - -guesstype boolean - -queryblocksize integer - -strict boolean - -timeout integer - -validate boolean - -headers list - } - set state(charset) $defaultCharset - set options { - -binary -blocksize -channel -command -guesstype -handler -headers -keepalive - -method -myaddr -progress -protocol -query -queryblocksize - -querychannel -queryprogress -strict -timeout -type -validate - } - set usage [join [lsort $options] ", "] - set options [string map {- ""} $options] - set pat ^-(?:[join $options |])$ - foreach {flag value} $args { - if {[regexp -- $pat $flag]} { - # Validate numbers - if { [info exists type($flag)] - && (![string is $type($flag) -strict $value]) - } { - unset $token - return -code error \ - "Bad value for $flag ($value), must be $type($flag)" - } - if {($flag eq "-headers") && ([llength $value] % 2 != 0)} { - unset $token - return -code error "Bad value for $flag ($value), number\ - of list elements must be even" - } - set state($flag) $value - } else { - unset $token - return -code error "Unknown option $flag, can be: $usage" - } - } - - # Make sure -query and -querychannel aren't both specified - - set isQueryChannel [info exists state(-querychannel)] - set isQuery [info exists state(-query)] - if {$isQuery && $isQueryChannel} { - unset $token - return -code error "Can't combine -query and -querychannel options!" - } - - # Validate URL, determine the server host and port, and check proxy case - # Recognize user:pass@host URLs also, although we do not do anything with - # that info yet. - - # URLs have basically four parts. - # First, before the colon, is the protocol scheme (e.g. http) - # Second, for HTTP-like protocols, is the authority - # The authority is preceded by // and lasts up to (but not including) - # the following / or ? and it identifies up to four parts, of which - # only one, the host, is required (if an authority is present at all). - # All other parts of the authority (user name, password, port number) - # are optional. - # Third is the resource name, which is split into two parts at a ? - # The first part (from the single "/" up to "?") is the path, and the - # second part (from that "?" up to "#") is the query. *HOWEVER*, we do - # not need to separate them; we send the whole lot to the server. - # Both, path and query are allowed to be missing, including their - # delimiting character. - # Fourth is the fragment identifier, which is everything after the first - # "#" in the URL. The fragment identifier MUST NOT be sent to the server - # and indeed, we don't bother to validate it (it could be an error to - # pass it in here, but it's cheap to strip). - # - # An example of a URL that has all the parts: - # - # http://jschmoe:xyzzy@www.bogus.net:8000/foo/bar.tml?q=foo#changes - # - # The "http" is the protocol, the user is "jschmoe", the password is - # "xyzzy", the host is "www.bogus.net", the port is "8000", the path is - # "/foo/bar.tml", the query is "q=foo", and the fragment is "changes". - # - # Note that the RE actually combines the user and password parts, as - # recommended in RFC 3986. Indeed, that RFC states that putting passwords - # in URLs is a Really Bad Idea, something with which I would agree utterly. - # RFC 9110 Sec 4.2.4 goes further than this, and deprecates the format - # "user:password@". It is retained here for backward compatibility, - # but its use is not recommended. - # - # From a validation perspective, we need to ensure that the parts of the - # URL that are going to the server are correctly encoded. This is only - # done if $state(-strict) is true (inherited from $::http::strict). - - set URLmatcher {(?x) # this is _expanded_ syntax - ^ - (?: (\w+) : ) ? # - (?: // - (?: - ( - [^@/\#?]+ # - ) @ - )? - ( # - [^/:\#?]+ | # host name or IPv4 address - \[ [^/\#?]+ \] # IPv6 address in square brackets - ) - (?: : (\d+) )? # - )? - ( [/\?] [^\#]*)? # (including query) - (?: \# (.*) )? # - $ - } - - # Phase one: parse - if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} { - unset $token - return -code error "Unsupported URL: $url" - } - # Phase two: validate - set host [string trim $host {[]}]; # strip square brackets from IPv6 address - if {$host eq ""} { - # Caller has to provide a host name; we do not have a "default host" - # that would enable us to handle relative URLs. - unset $token - return -code error "Missing host part: $url" - # Note that we don't check the hostname for validity here; if it's - # invalid, we'll simply fail to resolve it later on. - } - if {$port ne "" && $port > 65535} { - unset $token - return -code error "Invalid port number: $port" - } - # The user identification and resource identification parts of the URL can - # have encoded characters in them; take care! - if {$user ne ""} { - # Check for validity according to RFC 3986, Appendix A - set validityRE {(?xi) - ^ - (?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+ - $ - } - if {$state(-strict) && ![regexp -- $validityRE $user]} { - unset $token - # Provide a better error message in this error case - if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} { - return -code error \ - "Illegal encoding character usage \"$bad\" in URL user" - } - return -code error "Illegal characters in URL user" - } - } - if {$srvurl ne ""} { - # RFC 3986 allows empty paths (not even a /), but servers - # return 400 if the path in the HTTP request doesn't start - # with / , so add it here if needed. - if {[string index $srvurl 0] ne "/"} { - set srvurl /$srvurl - } - # Check for validity according to RFC 3986, Appendix A - set validityRE {(?xi) - ^ - # Path part (already must start with / character) - (?: [-\w.~!$&'()*+,;=:@/] | %[0-9a-f][0-9a-f] )* - # Query part (optional, permits ? characters) - (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )? - $ - } - if {$state(-strict) && ![regexp -- $validityRE $srvurl]} { - unset $token - # Provide a better error message in this error case - if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} { - return -code error \ - "Illegal encoding character usage \"$bad\" in URL path" - } - return -code error "Illegal characters in URL path" - } - if {![regexp {^[^?#]+} $srvurl state(path)]} { - set state(path) / - } - } else { - set srvurl / - set state(path) / - } - if {$proto eq ""} { - set proto http - } - set lower [string tolower $proto] - if {![info exists urlTypes($lower)]} { - unset $token - return -code error "Unsupported URL type \"$proto\"" - } - set defport [lindex $urlTypes($lower) 0] - set defcmd [lindex $urlTypes($lower) 1] - - if {$port eq ""} { - set port $defport - } - if {![catch {$http(-proxyfilter) $host} proxy]} { - set phost [lindex $proxy 0] - set pport [lindex $proxy 1] - } else { - set phost {} - set pport {} - } - - # OK, now reassemble into a full URL - set url ${proto}:// - if {$user ne ""} { - append url $user - append url @ - } - append url $host - if {$port != $defport} { - append url : $port - } - append url $srvurl - # Don't append the fragment! RFC 7230 Sec 5.1 - set state(url) $url - - # Proxy connections aren't shared among different hosts. - set state(socketinfo) $host:$port - - # Save the accept types at this point to prevent a race condition. [Bug - # c11a51c482] - set state(accept-types) $http(-accept) - - # Check whether this is an Upgrade request. - set connectionValues [SplitCommaSeparatedFieldValue \ - [GetFieldValue $state(-headers) Connection]] - set connectionValues [string tolower $connectionValues] - set upgradeValues [SplitCommaSeparatedFieldValue \ - [GetFieldValue $state(-headers) Upgrade]] - set state(upgradeRequest) [expr { "upgrade" in $connectionValues - && [llength $upgradeValues] >= 1}] - set state(connectionValues) $connectionValues - - if {$isQuery || $isQueryChannel} { - # It's a POST. - # A client wishing to send a non-idempotent request SHOULD wait to send - # that request until it has received the response status for the - # previous request. - if {$http(-postfresh)} { - # Override -keepalive for a POST. Use a new connection, and thus - # avoid the small risk of a race against server timeout. - set state(-keepalive) 0 - } else { - # Allow -keepalive but do not -pipeline - wait for the previous - # transaction to finish. - # There is a small risk of a race against server timeout. - set state(-pipeline) 0 - } - } elseif {$state(upgradeRequest)} { - # It's an upgrade request. Method must be GET (untested). - # Force -keepalive to 0 so the connection is not made over a persistent - # socket, i.e. one used for multiple HTTP requests. - set state(-keepalive) 0 - } else { - # It's a non-upgrade GET or HEAD. - set state(-pipeline) $http(-pipeline) - } - - # We cannot handle chunked encodings with -handler, so force HTTP/1.0 - # until we can manage this. - if {[info exists state(-handler)]} { - set state(-protocol) 1.0 - } - - # RFC 7320 A.1 - HTTP/1.0 Keep-Alive is problematic. We do not support it. - if {$state(-protocol) eq "1.0"} { - set state(connection) close - set state(-keepalive) 0 - } - - # Handle proxy requests here for http:// but not for https:// - # The proxying for https is done in the ::http::socketForTls command. - # A proxy request for http:// needs the full URL in the HTTP request line, - # including the server name. - # The *tls* test below attempts to describe protocols in addition to - # "https on port 443" that use HTTP over TLS. - if {($phost ne "") && (![string match -nocase *tls* $defcmd])} { - set srvurl $url - set targetAddr [list $phost $pport] - set state(proxyUsed) HttpProxy - # The value of state(proxyUsed) none|HttpProxy depends only on the - # all-transactions http::config settings and on the target URL. - # Even if this is a persistent socket there is no need to change the - # value of state(proxyUsed) for other transactions that use the socket: - # they have the same value already. - } else { - set targetAddr [list $host $port] - } - - set sockopts [list -async] - - # Pass -myaddr directly to the socket command - if {[info exists state(-myaddr)]} { - lappend sockopts -myaddr $state(-myaddr) - } - - set state(connArgs) [list $proto $phost $srvurl] - set state(openCmd) [list {*}$defcmd {*}$sockopts -type $token {*}$targetAddr] - - # See if we are supposed to use a previously opened channel. - # - In principle, ANY call to http::geturl could use a previously opened - # channel if it is available - the "Connection: keep-alive" header is a - # request to leave the channel open AFTER completion of this call. - # - In fact, we try to use an existing channel only if -keepalive 1 -- this - # means that at most one channel is left open for each value of - # $state(socketinfo). This property simplifies the mapping of open - # channels. - set reusing 0 - set state(alreadyQueued) 0 - set state(ReusingPlaceholder) 0 - if {$state(-keepalive)} { - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - if {[info exists socketMapping($state(socketinfo))]} { - # - If the connection is idle, it has a "fileevent readable" binding - # to http::CheckEof, in case the server times out and half-closes - # the socket (http::CheckEof closes the other half). - # - We leave this binding in place until just before the last - # puts+flush in http::Connected (GET/HEAD) or http::Write (POST), - # after which the HTTP response might be generated. - - if { [info exists socketClosing($state(socketinfo))] - && $socketClosing($state(socketinfo)) - } { - # socketClosing(*) is set because the server has sent a - # "Connection: close" header. - # Do not use the persistent socket again. - # Since we have only one persistent socket per server, and the - # old socket is not yet dead, add the request to the write queue - # of the dying socket, which will be replayed by ReplayIfClose. - # Also add it to socketWrQueue(*) which is used only if an error - # causes a call to Finish. - set reusing 1 - set sock $socketMapping($state(socketinfo)) - set state(proxyUsed) $socketProxyId($state(socketinfo)) - Log "reusing closing socket $sock for $state(socketinfo) - token $token" - - set state(alreadyQueued) 1 - lassign $socketPlayCmd($state(socketinfo)) com0 com1 com2 com3 - lappend com3 $token - set socketPlayCmd($state(socketinfo)) [list $com0 $com1 $com2 $com3] - lappend socketWrQueue($state(socketinfo)) $token - ##Log socketPlayCmd($state(socketinfo)) is $socketPlayCmd($state(socketinfo)) - ##Log socketWrQueue($state(socketinfo)) is $socketWrQueue($state(socketinfo)) - } elseif { - [catch {fconfigure $socketMapping($state(socketinfo))}] - && (![SockIsPlaceHolder $socketMapping($state(socketinfo))]) - } { - ###Log "Socket $socketMapping($state(socketinfo)) for $state(socketinfo)" - # FIXME Is it still possible for this code to be executed? If - # so, this could be another place to call TestForReplay, - # rather than discarding the queued transactions. - Log "WARNING: socket for $state(socketinfo) was closed\ - - token $token" - Log "WARNING - if testing, pay special attention to this\ - case (GH) which is seldom executed - token $token" - - # This will call CancelReadPipeline, CancelWritePipeline, and - # cancel any queued requests, responses. - Unset $state(socketinfo) - } else { - # Use the persistent socket. - # - The socket may not be ready to write: an earlier request might - # still be still writing (in the pipelined case) or - # writing/reading (in the nonpipeline case). This possibility - # is handled by socketWrQueue later in this command. - # - The socket may not yet exist, and be defined with a placeholder. - set reusing 1 - set sock $socketMapping($state(socketinfo)) - set state(proxyUsed) $socketProxyId($state(socketinfo)) - if {[SockIsPlaceHolder $sock]} { - set state(ReusingPlaceholder) 1 - lappend socketPhQueue($sock) $token - } else { - } - Log "reusing open socket $sock for $state(socketinfo) - token $token" - } - # Do not automatically close the connection socket. - set state(connection) keep-alive - } - } - - set state(reusing) $reusing - unset reusing - - if {![info exists sock]} { - # N.B. At this point ([info exists sock] == $state(reusing)). - # This will no longer be true after we set a value of sock here. - # Give the socket a placeholder name. - set sock HTTP_PLACEHOLDER_[incr TmpSockCounter] - } - set state(sock) $sock - - if {$state(reusing)} { - # Define these for use (only) by http::ReplayIfDead if the persistent - # connection has died. - set state(tmpConnArgs) $state(connArgs) - set state(tmpState) [array get state] - set state(tmpOpenCmd) $state(openCmd) - } - return $token -} - - -# ------------------------------------------------------------------------------ -# Proc ::http::SockIsPlaceHolder -# ------------------------------------------------------------------------------ -# Command to return 0 if the argument is a genuine socket handle, or 1 if is a -# placeholder value generated by geturl or ReplayCore before the real socket is -# created. -# -# Arguments: -# sock - either a valid socket handle or a placeholder value -# -# Return Value: 0 or 1 -# ------------------------------------------------------------------------------ - -proc http::SockIsPlaceHolder {sock} { - expr {[string range $sock 0 16] eq {HTTP_PLACEHOLDER_}} -} - - -# ------------------------------------------------------------------------------ -# state(reusing) -# ------------------------------------------------------------------------------ -# - state(reusing) is set by geturl, ReplayCore -# - state(reusing) is used by geturl, AsyncTransaction, OpenSocket, -# ConfigureNewSocket, and ScheduleRequest when creating and configuring the -# connection. -# - state(reusing) is used by Connect, Connected, Event x 2 when deciding -# whether to call TestForReplay. -# - Other places where state(reusing) is used: -# - Connected - if reusing and not pipelined, start the state(-timeout) -# timeout (when writing). -# - DoneRequest - if reusing and pipelined, send the next pipelined write -# - Event - if reusing and pipelined, start the state(-timeout) -# timeout (when reading). -# - Event - if (not reusing) and pipelined, send the next pipelined -# write. -# ------------------------------------------------------------------------------ - - -# ------------------------------------------------------------------------------ -# Proc http::AsyncTransaction -# ------------------------------------------------------------------------------ -# This command is called by geturl and ReplayCore to prepare the HTTP -# transaction prescribed by a suitably prepared token. -# -# Arguments: -# token - connection token (name of an array) -# -# Return Value: none -# ------------------------------------------------------------------------------ - -proc http::AsyncTransaction {token} { - variable $token - upvar 0 $token state - set tk [namespace tail $token] - - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - set sock $state(sock) - - # See comments above re the start of this timeout in other cases. - if {(!$state(reusing)) && ($state(-timeout) > 0)} { - set state(after) [after $state(-timeout) \ - [list http::reset $token timeout]] - } - - if { $state(-keepalive) - && (![info exists socketMapping($state(socketinfo))]) - } { - # This code is executed only for the first -keepalive request on a - # socket. It makes the socket persistent. - ##Log " PreparePersistentConnection" $token -- $sock -- DO - set DoLater [PreparePersistentConnection $token] - } else { - ##Log " PreparePersistentConnection" $token -- $sock -- SKIP - set DoLater {-traceread 0 -tracewrite 0} - } - - if {$state(ReusingPlaceholder)} { - # - This request was added to the socketPhQueue of a persistent - # connection. - # - But the connection has not yet been created and is a placeholder; - # - And the placeholder was created by an earlier request. - # - When that earlier request calls OpenSocket, its placeholder is - # replaced with a true socket, and it then executes the equivalent of - # OpenSocket for any subsequent requests that have - # $state(ReusingPlaceholder). - Log >J$tk after idle coro NO - ReusingPlaceholder - } elseif {$state(alreadyQueued)} { - # - This request was added to the socketWrQueue and socketPlayCmd - # of a persistent connection that will close at the end of its current - # read operation. - Log >J$tk after idle coro NO - alreadyQueued - } else { - Log >J$tk after idle coro YES - set CoroName ${token}--SocketCoroutine - set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \ - $token $DoLater]] - dict set socketCoEvent($state(socketinfo)) $token $cancel - set state(socketcoro) $cancel - } - - return -} - - -# ------------------------------------------------------------------------------ -# Proc http::PreparePersistentConnection -# ------------------------------------------------------------------------------ -# This command is called by AsyncTransaction to initialise a "persistent -# connection" based upon a socket placeholder. It is called the first time the -# socket is associated with a "-keepalive" request. -# -# Arguments: -# token - connection token (name of an array) -# -# Return Value: - DoLater, a dictionary of boolean values listing unfinished -# tasks; to be passed to ConfigureNewSocket via OpenSocket. -# ------------------------------------------------------------------------------ - -proc http::PreparePersistentConnection {token} { - variable $token - upvar 0 $token state - - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - set DoLater {-traceread 0 -tracewrite 0} - set socketMapping($state(socketinfo)) $state(sock) - set socketProxyId($state(socketinfo)) $state(proxyUsed) - # - The value of state(proxyUsed) was set in http::CreateToken to either - # "none" or "HttpProxy". - # - $token is the first transaction to use this placeholder, so there are - # no other tokens whose (proxyUsed) must be modified. - - if {![info exists socketRdState($state(socketinfo))]} { - set socketRdState($state(socketinfo)) {} - # set varName ::http::socketRdState($state(socketinfo)) - # trace add variable $varName unset ::http::CancelReadPipeline - dict set DoLater -traceread 1 - } - if {![info exists socketWrState($state(socketinfo))]} { - set socketWrState($state(socketinfo)) {} - # set varName ::http::socketWrState($state(socketinfo)) - # trace add variable $varName unset ::http::CancelWritePipeline - dict set DoLater -tracewrite 1 - } - - if {$state(-pipeline)} { - #Log new, init for pipelined, GRANT write access to $token in geturl - # Also grant premature read access to the socket. This is OK. - set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token - } else { - # socketWrState is not used by this non-pipelined transaction. - # We cannot leave it as "Wready" because the next call to - # http::geturl with a pipelined transaction would conclude that the - # socket is available for writing. - #Log new, init for nonpipeline, GRANT r/w access to $token in geturl - set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token - } - - # Value of socketPhQueue() may have already been set by ReplayCore. - if {![info exists socketPhQueue($state(sock))]} { - set socketPhQueue($state(sock)) {} - } - set socketRdQueue($state(socketinfo)) {} - set socketWrQueue($state(socketinfo)) {} - set socketClosing($state(socketinfo)) 0 - set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} - set socketCoEvent($state(socketinfo)) {} - set socketProxyId($state(socketinfo)) {} - - return $DoLater -} - -# ------------------------------------------------------------------------------ -# Proc ::http::OpenSocket -# ------------------------------------------------------------------------------ -# This command is called as a coroutine idletask to start the asynchronous HTTP -# transaction in most cases. For the exceptions, see the calling code in -# command AsyncTransaction. -# -# Arguments: -# token - connection token (name of an array) -# DoLater - dictionary of boolean values listing unfinished tasks -# -# Return Value: none -# ------------------------------------------------------------------------------ - -proc http::OpenSocket {token DoLater} { - variable $token - upvar 0 $token state - set tk [namespace tail $token] - - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - Log >K$tk Start OpenSocket coroutine - - if {![info exists state(-keepalive)]} { - # The request has already been cancelled by the calling script. - return - } - - set sockOld $state(sock) - - dict unset socketCoEvent($state(socketinfo)) $token - unset -nocomplain state(socketcoro) - - if {[catch { - if {$state(reusing)} { - # If ($state(reusing)) is true, then we do not need to create a new - # socket, even if $sockOld is only a placeholder for a socket. - set sock $sockOld - } else { - # set sock in the [catch] below. - set pre [clock milliseconds] - ##Log pre socket opened, - token $token - ##Log $state(openCmd) - token $token - set sock [namespace eval :: $state(openCmd)] - set state(sock) $sock - # Normal return from $state(openCmd) always returns a valid socket. - # A TLS proxy connection with 407 or other failure from the - # proxy server raises an error. - - # Initialisation of a new socket. - ##Log post socket opened, - token $token - ##Log socket opened, now fconfigure - token $token - set delay [expr {[clock milliseconds] - $pre}] - if {$delay > 3000} { - Log socket delay $delay - token $token - } - fconfigure $sock -translation {auto crlf} \ - -buffersize $state(-blocksize) - if {[package vsatisfies [package provide Tcl] 9.0-]} { - fconfigure $sock -profile tcl8 - } - ##Log socket opened, DONE fconfigure - token $token - } - - Log "Using $sock for $state(socketinfo) - token $token" \ - [expr {$state(-keepalive)?"keepalive":""}] - - # Code above has set state(sock) $sock - ConfigureNewSocket $token $sockOld $DoLater - ##Log OpenSocket success $sock - token $token - } result errdict]} { - ##Log OpenSocket failed $result - token $token - # There may be other requests in the socketPhQueue. - # Prepare socketPlayCmd so that Finish will replay them. - if { ($state(-keepalive)) && (!$state(reusing)) - && [info exists socketPhQueue($sockOld)] - && ($socketPhQueue($sockOld) ne {}) - } { - if {$socketMapping($state(socketinfo)) ne $sockOld} { - Log "WARNING: this code should not be reached.\ - {$socketMapping($state(socketinfo)) ne $sockOld}" - } - set socketPlayCmd($state(socketinfo)) [list ReplayIfClose Wready {} $socketPhQueue($sockOld)] - set socketPhQueue($sockOld) {} - } - if {[string range $result 0 20] eq {proxy connect failed:}} { - # - The HTTPS proxy did not create a socket. The pre-existing value - # (a "placeholder socket") is unchanged. - # - The proxy returned a valid HTTP response to the failed CONNECT - # request, and http::SecureProxyConnect copied this to $token, - # and also set ${token}(connection) set to "close". - # - Remove the error message $result so that Finish delivers this - # HTTP response to the caller. - set result {} - } - Finish $token $result - # Because socket creation failed, the placeholder "socket" must be - # "closed" and (if persistent) removed from the persistent sockets - # table. In the {proxy connect failed:} case Finish does this because - # the value of ${token}(connection) is "close". In the other cases here, - # it does so because $result is non-empty. - } - ##Log Leaving http::OpenSocket coroutine [info coroutine] - token $token - return -} - - -# ------------------------------------------------------------------------------ -# Proc ::http::ConfigureNewSocket -# ------------------------------------------------------------------------------ -# Command to initialise a newly-created socket. Called only from OpenSocket. -# -# This command is called by OpenSocket whenever a genuine socket (sockNew) has -# been opened for for use by HTTP. It does two things: -# (1) If $token uses a placeholder socket, this command replaces the placeholder -# socket with the real socket, not only in $token but in all other requests -# that use the same placeholder. -# (2) It calls ScheduleRequest to schedule each request that uses the socket. -# -# -# Value of sockOld/sockNew can be "sock" (genuine socket) or "ph" (placeholder). -# sockNew is ${token}(sock) -# sockOld sockNew CASES -# sock sock (if $reusing, and sockOld is sock) -# ph sock (if (not $reusing), and sockOld is ph) -# ph ph (if $reusing, and sockOld is ph) - not called in this case -# sock ph (cannot occur unless a bug) - not called in this case -# (if (not $reusing), and sockOld is sock) - illogical -# -# Arguments: -# token - connection token (name of an array) -# sockOld - handle or placeholder used for a socket before the call to -# OpenSocket -# DoLater - dictionary of boolean values listing unfinished tasks -# -# Return Value: none -# ------------------------------------------------------------------------------ - -proc http::ConfigureNewSocket {token sockOld DoLater} { - variable $token - upvar 0 $token state - set tk [namespace tail $token] - - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - set reusing $state(reusing) - set sock $state(sock) - set proxyUsed $state(proxyUsed) - ##Log " ConfigureNewSocket" $token $sockOld ... -- $reusing $sock $proxyUsed - - if {(!$reusing) && ($sock ne $sockOld)} { - # Replace the placeholder value sockOld with sock. - - if { [info exists socketMapping($state(socketinfo))] - && ($socketMapping($state(socketinfo)) eq $sockOld) - } { - set socketMapping($state(socketinfo)) $sock - set socketProxyId($state(socketinfo)) $proxyUsed - # tokens that use the placeholder $sockOld are updated below. - ##Log set socketMapping($state(socketinfo)) $sock - } - - # Now finish any tasks left over from PreparePersistentConnection on - # the connection. - # - # The "unset" traces are fired by init (clears entire arrays), and - # by http::Unset. - # Unset is called by CloseQueuedQueries and (possibly never) by geturl. - # - # CancelReadPipeline, CancelWritePipeline call http::Finish for each - # token. - # - # FIXME If Finish is placeholder-aware, these traces can be set earlier, - # in PreparePersistentConnection. - - if {[dict get $DoLater -traceread]} { - set varName ::http::socketRdState($state(socketinfo)) - trace add variable $varName unset ::http::CancelReadPipeline - } - if {[dict get $DoLater -tracewrite]} { - set varName ::http::socketWrState($state(socketinfo)) - trace add variable $varName unset ::http::CancelWritePipeline - } - } - - # Do this in all cases. - ScheduleRequest $token - - # Now look at all other tokens that use the placeholder $sockOld. - if { (!$reusing) - && ($sock ne $sockOld) - && [info exists socketPhQueue($sockOld)] - } { - ##Log " ConfigureNewSocket" $token scheduled, now do $socketPhQueue($sockOld) - foreach tok $socketPhQueue($sockOld) { - # 1. Amend the token's (sock). - ##Log set ${tok}(sock) $sock - set ${tok}(sock) $sock - set ${tok}(proxyUsed) $proxyUsed - - # 2. Schedule the token's HTTP request. - # Every token in socketPhQueue(*) has reusing 1 alreadyQueued 0. - set ${tok}(reusing) 1 - set ${tok}(alreadyQueued) 0 - ScheduleRequest $tok - } - set socketPhQueue($sockOld) {} - } - ##Log " ConfigureNewSocket" $token DONE - - return -} - - -# ------------------------------------------------------------------------------ -# The values of array variables socketMapping etc. -# ------------------------------------------------------------------------------ -# connId "$host:$port" -# socketMapping($connId) the handle or placeholder for the socket that is used -# for "-keepalive 1" requests to $connId. -# socketRdState($connId) the token that is currently reading from the socket. -# Other values: Rready (ready for next token to read). -# socketWrState($connId) the token that is currently writing to the socket. -# Other values: Wready (ready for next token to write), -# peNding (would be ready for next write, except that -# the integrity of a non-pipelined transaction requires -# waiting until the read(s) in progress are finished). -# socketRdQueue($connId) List of tokens that are queued for reading later. -# socketWrQueue($connId) List of tokens that are queued for writing later. -# socketPhQueue($sock) List of tokens that are queued to use a placeholder -# socket, when the real socket has not yet been created. -# socketClosing($connId) (boolean) true iff a server response header indicates -# that the server will close the connection at the end of -# the current response. -# socketPlayCmd($connId) The command to execute to replay pending and -# part-completed transactions if the socket closes early. -# socketCoEvent($connId) Identifier for the "after idle" event that will launch -# an OpenSocket coroutine to open or re-use a socket. -# socketProxyId($connId) The type of proxy that this socket uses: values are -# those of state(proxyUsed) i.e. none, HttpProxy, -# SecureProxy, and SecureProxyFailed. -# The value is not used for anything by http, its purpose -# is to set the value of state() for caller information. -# ------------------------------------------------------------------------------ - - -# ------------------------------------------------------------------------------ -# Using socketWrState(*), socketWrQueue(*), socketRdState(*), socketRdQueue(*) -# ------------------------------------------------------------------------------ -# The element socketWrState($connId) has a value which is either the name of -# the token that is permitted to write to the socket, or "Wready" if no -# token is permitted to write. -# -# The code that sets the value to Wready immediately calls -# http::NextPipelinedWrite, which examines socketWrQueue($connId) and -# processes the next request in the queue, if there is one. The value -# Wready is not found when the interpreter is in the event loop unless the -# socket is idle. -# -# The element socketRdState($connId) has a value which is either the name of -# the token that is permitted to read from the socket, or "Rready" if no -# token is permitted to read. -# -# The code that sets the value to Rready then examines -# socketRdQueue($connId) and processes the next request in the queue, if -# there is one. The value Rready is not found when the interpreter is in -# the event loop unless the socket is idle. -# ------------------------------------------------------------------------------ - - -# ------------------------------------------------------------------------------ -# Proc http::ScheduleRequest -# ------------------------------------------------------------------------------ -# Command to either begin the HTTP request, or add it to the appropriate queue. -# Called from two places in ConfigureNewSocket. -# -# Arguments: -# token - connection token (name of an array) -# -# Return Value: none -# ------------------------------------------------------------------------------ - -proc http::ScheduleRequest {token} { - variable $token - upvar 0 $token state - set tk [namespace tail $token] - - Log >L$tk ScheduleRequest - - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - set Unfinished 0 - - set reusing $state(reusing) - set sockNew $state(sock) - - # The "if" tests below: must test against the current values of - # socketWrState, socketRdState, and so the tests must be done here, - # not earlier in PreparePersistentConnection. - - if {$state(alreadyQueued)} { - # The request has been appended to the queue of a persistent socket - # (that is scheduled to close and have its queue replayed). - # - # A write may or may not be in progress. There is no need to set - # socketWrState to prevent another call stealing write access - all - # subsequent calls on this socket will come here because the socket - # will close after the current read, and its - # socketClosing($connId) is 1. - ##Log "HTTP request for token $token is queued" - - } elseif { $reusing - && $state(-pipeline) - && ($socketWrState($state(socketinfo)) ne "Wready") - } { - ##Log "HTTP request for token $token is queued for pipelined use" - lappend socketWrQueue($state(socketinfo)) $token - - } elseif { $reusing - && (!$state(-pipeline)) - && ($socketWrState($state(socketinfo)) ne "Wready") - } { - # A write is queued or in progress. Lappend to the write queue. - ##Log "HTTP request for token $token is queued for nonpipeline use" - lappend socketWrQueue($state(socketinfo)) $token - - } elseif { $reusing - && (!$state(-pipeline)) - && ($socketWrState($state(socketinfo)) eq "Wready") - && ($socketRdState($state(socketinfo)) ne "Rready") - } { - # A read is queued or in progress, but not a write. Cannot start the - # nonpipeline transaction, but must set socketWrState to prevent a - # pipelined request jumping the queue. - ##Log "HTTP request for token $token is queued for nonpipeline use" - #Log re-use nonpipeline, GRANT delayed write access to $token in geturl - set socketWrState($state(socketinfo)) peNding - lappend socketWrQueue($state(socketinfo)) $token - - } else { - if {$reusing && $state(-pipeline)} { - #Log new, init for pipelined, GRANT write access to $token in geturl - # DO NOT grant premature read access to the socket. - # set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token - } elseif {$reusing} { - # socketWrState is not used by this non-pipelined transaction. - # We cannot leave it as "Wready" because the next call to - # http::geturl with a pipelined transaction would conclude that the - # socket is available for writing. - #Log new, init for nonpipeline, GRANT r/w access to $token in geturl - set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token - } else { - } - - # Process the request now. - # - Command is not called unless $state(sock) is a real socket handle - # and not a placeholder. - # - All (!$reusing) cases come here. - # - Some $reusing cases come here too if the connection is - # marked as ready. Those $reusing cases are: - # $reusing && ($socketWrState($state(socketinfo)) eq "Wready") && - # EITHER !$pipeline && ($socketRdState($state(socketinfo)) eq "Rready") - # OR $pipeline - # - #Log ---- $state(socketinfo) << conn to $token for HTTP request (a) - ##Log " ScheduleRequest" $token -- fileevent $state(sock) writable for $token - # Connect does its own fconfigure. - - lassign $state(connArgs) proto phost srvurl - - if {[catch { - fileevent $state(sock) writable \ - [list http::Connect $token $proto $phost $srvurl] - } res opts]} { - # The socket no longer exists. - ##Log bug -- socket gone -- $res -- $opts - } - - } - - return -} - - -# ------------------------------------------------------------------------------ -# Proc http::SendHeader -# ------------------------------------------------------------------------------ -# Command to send a request header, and keep a copy in state(requestHeaders) -# for debugging purposes. -# -# Arguments: -# token - connection token (name of an array) -# key - header name -# value - header value -# -# Return Value: none -# ------------------------------------------------------------------------------ - -proc http::SendHeader {token key value} { - variable $token - upvar 0 $token state - set tk [namespace tail $token] - set sock $state(sock) - lappend state(requestHeaders) [string tolower $key] $value - puts $sock "$key: $value" - return -} - -# http::Connected -- -# -# Callback used when the connection to the HTTP server is actually -# established. -# -# Arguments: -# token State token. -# proto What protocol (http, https, etc.) was used to connect. -# phost Are we using keep-alive? Non-empty if yes. -# srvurl Service-local URL that we're requesting -# Results: -# None. - -proc http::Connected {token proto phost srvurl} { - variable http - variable urlTypes - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - variable $token - upvar 0 $token state - set tk [namespace tail $token] - - if {$state(reusing) && (!$state(-pipeline)) && ($state(-timeout) > 0)} { - set state(after) [after $state(-timeout) \ - [list http::reset $token timeout]] - } - - # Set back the variables needed here. - set sock $state(sock) - set isQueryChannel [info exists state(-querychannel)] - set isQuery [info exists state(-query)] - regexp {^(.+):([^:]+)$} $state(socketinfo) {} host port - - set lower [string tolower $proto] - set defport [lindex $urlTypes($lower) 0] - - # Send data in cr-lf format, but accept any line terminators. - # Initialisation to {auto *} now done in geturl, KeepSocket and DoneRequest. - # We are concerned here with the request (write) not the response (read). - lassign [fconfigure $sock -translation] trRead trWrite - fconfigure $sock -translation [list $trRead crlf] \ - -buffersize $state(-blocksize) - if {[package vsatisfies [package provide Tcl] 9.0-]} { - fconfigure $sock -profile tcl8 - } - - # The following is disallowed in safe interpreters, but the socket is - # already in non-blocking mode in that case. - - catch {fconfigure $sock -blocking off} - set how GET - if {$isQuery} { - set state(querylength) [string length $state(-query)] - if {$state(querylength) > 0} { - set how POST - set contDone 0 - } else { - # There's no query data. - unset state(-query) - set isQuery 0 - } - } elseif {$state(-validate)} { - set how HEAD - } elseif {$isQueryChannel} { - set how POST - # The query channel must be blocking for the async Write to - # work properly. - fconfigure $state(-querychannel) -blocking 1 -translation binary - set contDone 0 - } - if {[info exists state(-method)] && ($state(-method) ne "")} { - set how $state(-method) - } - set accept_types_seen 0 - - Log ^B$tk begin sending request - token $token - - if {[catch { - if {[info exists state(bypass)]} { - set state(method) [lindex [split $state(bypass) { }] 0] - set state(requestHeaders) {} - set state(requestLine) $state(bypass) - } else { - set state(method) $how - set state(requestHeaders) {} - set state(requestLine) "$how $srvurl HTTP/$state(-protocol)" - } - puts $sock $state(requestLine) - set hostValue [GetFieldValue $state(-headers) Host] - if {$hostValue ne {}} { - # Allow Host spoofing. [Bug 928154] - regexp {^[^:]+} $hostValue state(host) - SendHeader $token Host $hostValue - } elseif {$port == $defport} { - # Don't add port in this case, to handle broken servers. [Bug - # #504508] - set state(host) $host - SendHeader $token Host $host - } else { - set state(host) $host - SendHeader $token Host "$host:$port" - } - SendHeader $token User-Agent $http(-useragent) - if {($state(-protocol) > 1.0) && $state(-keepalive)} { - # Send this header, because a 1.1 server is not compelled to treat - # this as the default. - set ConnVal keep-alive - } elseif {($state(-protocol) > 1.0)} { - # RFC2616 sec 8.1.2.1 - set ConnVal close - } else { - # ($state(-protocol) <= 1.0) - # RFC7230 A.1 - # Some server implementations of HTTP/1.0 have a faulty - # implementation of RFC 2068 Keep-Alive. - # Don't leave this to chance. - # For HTTP/1.0 we have already "set state(connection) close" - # and "state(-keepalive) 0". - set ConnVal close - } - # Proxy authorisation (cf. mod by Anders Ramdahl to autoproxy by - # Pat Thoyts). - if {($http(-proxyauth) ne {}) && ($state(proxyUsed) eq {HttpProxy})} { - SendHeader $token Proxy-Authorization $http(-proxyauth) - } - # RFC7230 A.1 - "clients are encouraged not to send the - # Proxy-Connection header field in any requests" - set accept_encoding_seen 0 - set content_type_seen 0 - set connection_seen 0 - foreach {key value} $state(-headers) { - set value [string map [list \n "" \r ""] $value] - set key [string map {" " -} [string trim $key]] - if {[string equal -nocase $key "host"]} { - continue - } - if {[string equal -nocase $key "accept-encoding"]} { - set accept_encoding_seen 1 - } - if {[string equal -nocase $key "accept"]} { - set accept_types_seen 1 - } - if {[string equal -nocase $key "content-type"]} { - set content_type_seen 1 - } - if {[string equal -nocase $key "content-length"]} { - set contDone 1 - set state(querylength) $value - } - if { [string equal -nocase $key "connection"] - && [info exists state(bypass)] - } { - # Value supplied in -headers overrides $ConnVal. - set connection_seen 1 - } elseif {[string equal -nocase $key "connection"]} { - # Remove "close" or "keep-alive" and use our own value. - # In an upgrade request, the upgrade is not guaranteed. - # Value "close" or "keep-alive" tells the server what to do - # if it refuses the upgrade. We send a single "Connection" - # header because some websocket servers, e.g. civetweb, reject - # multiple headers. Bug [d01de3281f] of tcllib/websocket. - set connection_seen 1 - set listVal $state(connectionValues) - if {[set pos [lsearch $listVal close]] != -1} { - set listVal [lreplace $listVal $pos $pos] - } - if {[set pos [lsearch $listVal keep-alive]] != -1} { - set listVal [lreplace $listVal $pos $pos] - } - lappend listVal $ConnVal - set value [join $listVal {, }] - } - if {[string length $key]} { - SendHeader $token $key $value - } - } - # Allow overriding the Accept header on a per-connection basis. Useful - # for working with REST services. [Bug c11a51c482] - if {!$accept_types_seen} { - SendHeader $token Accept $state(accept-types) - } - if { (!$accept_encoding_seen) - && (![info exists state(-handler)]) - && $http(-zip) - } { - SendHeader $token Accept-Encoding gzip,deflate - } elseif {!$accept_encoding_seen} { - SendHeader $token Accept-Encoding identity - } else { - } - if {!$connection_seen} { - SendHeader $token Connection $ConnVal - } - if {$isQueryChannel && ($state(querylength) == 0)} { - # Try to determine size of data in channel. If we cannot seek, the - # surrounding catch will trap us - - set start [tell $state(-querychannel)] - seek $state(-querychannel) 0 end - set state(querylength) \ - [expr {[tell $state(-querychannel)] - $start}] - seek $state(-querychannel) $start - } - - # Note that we don't do Cookie2; that's much nastier and not normally - # observed in practice either. It also doesn't fix the multitude of - # bugs in the basic cookie spec. - if {$http(-cookiejar) ne ""} { - set cookies "" - set separator "" - foreach {key value} [{*}$http(-cookiejar) \ - getCookies $proto $host $state(path)] { - append cookies $separator $key = $value - set separator "; " - } - if {$cookies ne ""} { - SendHeader $token Cookie $cookies - } - } - - # Flush the request header and set up the fileevent that will either - # push the POST data or read the response. - # - # fileevent note: - # - # It is possible to have both the read and write fileevents active at - # this point. The only scenario it seems to affect is a server that - # closes the connection without reading the POST data. (e.g., early - # versions TclHttpd in various error cases). Depending on the - # platform, the client may or may not be able to get the response from - # the server because of the error it will get trying to write the post - # data. Having both fileevents active changes the timing and the - # behavior, but no two platforms (among Solaris, Linux, and NT) behave - # the same, and none behave all that well in any case. Servers should - # always read their POST data if they expect the client to read their - # response. - - if {$isQuery || $isQueryChannel} { - # POST method. - if {!$content_type_seen} { - SendHeader $token Content-Type $state(-type) - } - if {!$contDone} { - SendHeader $token Content-Length $state(querylength) - } - puts $sock "" - flush $sock - # Flush flushes the error in the https case with a bad handshake: - # else the socket never becomes writable again, and hangs until - # timeout (if any). - - lassign [fconfigure $sock -translation] trRead trWrite - fconfigure $sock -translation [list $trRead binary] - fileevent $sock writable [list http::Write $token] - # The http::Write command decides when to make the socket readable, - # using the same test as the GET/HEAD case below. - } else { - # GET or HEAD method. - if { (![catch {fileevent $sock readable} binding]) - && ($binding eq [list http::CheckEof $sock]) - } { - # Remove the "fileevent readable" binding of an idle persistent - # socket to http::CheckEof. We can no longer treat bytes - # received as junk. The server might still time out and - # half-close the socket if it has not yet received the first - # "puts". - fileevent $sock readable {} - } - puts $sock "" - flush $sock - Log ^C$tk end sending request - token $token - # End of writing (GET/HEAD methods). The request has been sent. - - DoneRequest $token - } - - } err]} { - # The socket probably was never connected, OR the connection dropped - # later, OR https handshake error, which may be discovered as late as - # the "flush" command above... - Log "WARNING - if testing, pay special attention to this\ - case (GI) which is seldom executed - token $token" - if {[info exists state(reusing)] && $state(reusing)} { - # The socket was closed at the server end, and closed at - # this end by http::CheckEof. - if {[TestForReplay $token write $err a]} { - return - } else { - Finish $token {failed to re-use socket} - } - - # else: - # This is NOT a persistent socket that has been closed since its - # last use. - # If any other requests are in flight or pipelined/queued, they will - # be discarded. - } elseif {$state(status) eq ""} { - # https handshake errors come here, for - # Tcl 8.7 without http::SecureProxyConnect, and for Tcl 8.6. - set msg [registerError $sock] - registerError $sock {} - if {$msg eq {}} { - set msg {failed to use socket} - } - Finish $token $msg - } elseif {$state(status) ne "error"} { - Finish $token $err - } - } - return -} - -# http::registerError -# -# Called (for example when processing TclTLS activity) to register -# an error for a connection on a specific socket. This helps -# http::Connected to deliver meaningful error messages, e.g. when a TLS -# certificate fails verification. -# -# Usage: http::registerError socket ?newValue? -# -# "set" semantics, except that a "get" (a call without a new value) for a -# non-existent socket returns {}, not an error. - -proc http::registerError {sock args} { - variable registeredErrors - - if { ([llength $args] == 0) - && (![info exists registeredErrors($sock)]) - } { - return - } elseif { ([llength $args] == 1) - && ([lindex $args 0] eq {}) - } { - unset -nocomplain registeredErrors($sock) - return - } - set registeredErrors($sock) {*}$args -} - -# http::DoneRequest -- -# -# Command called when a request has been sent. It will arrange the -# next request and/or response as appropriate. -# -# If this command is called when $socketClosing(*), the request $token -# that calls it must be pipelined and destined to fail. - -proc http::DoneRequest {token} { - variable http - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - variable $token - upvar 0 $token state - set tk [namespace tail $token] - set sock $state(sock) - - # If pipelined, connect the next HTTP request to the socket. - if {$state(reusing) && $state(-pipeline)} { - # Enable next token (if any) to write. - # The value "Wready" is set only here, and - # in http::Event after reading the response-headers of a - # non-reusing transaction. - # Previous value is $token. It cannot be pending. - set socketWrState($state(socketinfo)) Wready - - # Now ready to write the next pipelined request (if any). - http::NextPipelinedWrite $token - } else { - # If pipelined, this is the first transaction on this socket. We wait - # for the response headers to discover whether the connection is - # persistent. (If this is not done and the connection is not - # persistent, we SHOULD retry and then MUST NOT pipeline before knowing - # that we have a persistent connection - # (rfc2616 8.1.2.2)). - } - - # Connect to receive the response, unless the socket is pipelined - # and another response is being sent. - # This code block is separate from the code below because there are - # cases where socketRdState already has the value $token. - if { $state(-keepalive) - && $state(-pipeline) - && [info exists socketRdState($state(socketinfo))] - && ($socketRdState($state(socketinfo)) eq "Rready") - } { - #Log pipelined, GRANT read access to $token in Connected - set socketRdState($state(socketinfo)) $token - } - - if { $state(-keepalive) - && $state(-pipeline) - && [info exists socketRdState($state(socketinfo))] - && ($socketRdState($state(socketinfo)) ne $token) - } { - # Do not read from the socket until it is ready. - ##Log "HTTP response for token $token is queued for pipelined use" - # If $socketClosing(*), then the caller will be a pipelined write and - # execution will come here. - # This token has already been recorded as "in flight" for writing. - # When the socket is closed, the read queue will be cleared in - # CloseQueuedQueries and so the "lappend" here has no effect. - lappend socketRdQueue($state(socketinfo)) $token - } else { - # In the pipelined case, connection for reading depends on the - # value of socketRdState. - # In the nonpipeline case, connection for reading always occurs. - ReceiveResponse $token - } - return -} - -# http::ReceiveResponse -# -# Connects token to its socket for reading. - -proc http::ReceiveResponse {token} { - variable $token - upvar 0 $token state - set tk [namespace tail $token] - set sock $state(sock) - - #Log ---- $state(socketinfo) >> conn to $token for HTTP response - lassign [fconfigure $sock -translation] trRead trWrite - fconfigure $sock -translation [list auto $trWrite] \ - -buffersize $state(-blocksize) - if {[package vsatisfies [package provide Tcl] 9.0-]} { - fconfigure $sock -profile tcl8 - } - Log ^D$tk begin receiving response - token $token - - coroutine ${token}--EventCoroutine http::Event $sock $token - if {[info exists state(-handler)] || [info exists state(-progress)]} { - fileevent $sock readable [list http::EventGateway $sock $token] - } else { - fileevent $sock readable ${token}--EventCoroutine - } - return -} - - -# http::EventGateway -# -# Bug [c2dc1da315]. -# - Recursive launch of the coroutine can occur if a -handler or -progress -# callback is used, and the callback command enters the event loop. -# - To prevent this, the fileevent "binding" is disabled while the -# coroutine is in flight. -# - If a recursive call occurs despite these precautions, it is not -# trapped and discarded here, because it is better to report it as a -# bug. -# - Although this solution is believed to be sufficiently general, it is -# used only if -handler or -progress is specified. In other cases, -# the coroutine is called directly. - -proc http::EventGateway {sock token} { - variable $token - upvar 0 $token state - fileevent $sock readable {} - catch {${token}--EventCoroutine} res opts - if {[info commands ${token}--EventCoroutine] ne {}} { - # The coroutine can be deleted by completion (a non-yield return), by - # http::Finish (when there is a premature end to the transaction), by - # http::reset or http::cleanup, or if the caller set option -channel - # but not option -handler: in the last case reading from the socket is - # now managed by commands ::http::Copy*, http::ReceiveChunked, and - # http::MakeTransformationChunked. - # - # Catch in case the coroutine has closed the socket. - catch {fileevent $sock readable [list http::EventGateway $sock $token]} - } - - # If there was an error, re-throw it. - return -options $opts $res -} - - -# http::NextPipelinedWrite -# -# - Connecting a socket to a token for writing is done by this command and by -# command KeepSocket. -# - If another request has a pipelined write scheduled for $token's socket, -# and if the socket is ready to accept it, connect the write and update -# the queue accordingly. -# - This command is called from http::DoneRequest and http::Event, -# IF $state(-pipeline) AND (the current transfer has reached the point at -# which the socket is ready for the next request to be written). -# - This command is called when a token has write access and is pipelined and -# keep-alive, and sets socketWrState to Wready. -# - The command need not consider the case where socketWrState is set to a token -# that does not yet have write access. Such a token is waiting for Rready, -# and the assignment of the connection to the token will be done elsewhere (in -# http::KeepSocket). -# - This command cannot be called after socketWrState has been set to a -# "pending" token value (that is then overwritten by the caller), because that -# value is set by this command when it is called by an earlier token when it -# relinquishes its write access, and the pending token is always the next in -# line to write. - -proc http::NextPipelinedWrite {token} { - variable http - variable socketRdState - variable socketWrState - variable socketWrQueue - variable socketClosing - variable $token - upvar 0 $token state - set connId $state(socketinfo) - - if { [info exists socketClosing($connId)] - && $socketClosing($connId) - } { - # socketClosing(*) is set because the server has sent a - # "Connection: close" header. - # Behave as if the queues are empty - so do nothing. - } elseif { $state(-pipeline) - && [info exists socketWrState($connId)] - && ($socketWrState($connId) eq "Wready") - - && [info exists socketWrQueue($connId)] - && [llength $socketWrQueue($connId)] - && ([set token2 [lindex $socketWrQueue($connId) 0] - set ${token2}(-pipeline) - ] - ) - } { - # - The usual case for a pipelined connection, ready for a new request. - #Log pipelined, GRANT write access to $token2 in NextPipelinedWrite - set conn [set ${token2}(connArgs)] - set socketWrState($connId) $token2 - set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] - # Connect does its own fconfigure. - fileevent $state(sock) writable [list http::Connect $token2 {*}$conn] - #Log ---- $connId << conn to $token2 for HTTP request (b) - - # In the tests below, the next request will be nonpipeline. - } elseif { $state(-pipeline) - && [info exists socketWrState($connId)] - && ($socketWrState($connId) eq "Wready") - - && [info exists socketWrQueue($connId)] - && [llength $socketWrQueue($connId)] - && (![ set token3 [lindex $socketWrQueue($connId) 0] - set ${token3}(-pipeline) - ] - ) - - && [info exists socketRdState($connId)] - && ($socketRdState($connId) eq "Rready") - } { - # The case in which the next request will be non-pipelined, and the read - # and write queues is ready: which is the condition for a non-pipelined - # write. - set conn [set ${token3}(connArgs)] - #Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite - set socketRdState($connId) $token3 - set socketWrState($connId) $token3 - set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] - # Connect does its own fconfigure. - fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] - #Log ---- $state(sock) << conn to $token3 for HTTP request (c) - - } elseif { $state(-pipeline) - && [info exists socketWrState($connId)] - && ($socketWrState($connId) eq "Wready") - - && [info exists socketWrQueue($connId)] - && [llength $socketWrQueue($connId)] - && (![set token2 [lindex $socketWrQueue($connId) 0] - set ${token2}(-pipeline) - ] - ) - } { - # - The case in which the next request will be non-pipelined, but the - # read queue is NOT ready. - # - A read is queued or in progress, but not a write. Cannot start the - # nonpipeline transaction, but must set socketWrState to prevent a new - # pipelined request (in http::geturl) jumping the queue. - # - Because socketWrState($connId) is not set to Wready, the assignment - # of the connection to $token2 will be done elsewhere - by command - # http::KeepSocket when $socketRdState($connId) is set to "Rready". - - #Log re-use nonpipeline, GRANT delayed write access to $token in NextP.. - set socketWrState($connId) peNding - } - return -} - -# http::CancelReadPipeline -# -# Cancel pipelined responses on a closing "Keep-Alive" socket. -# -# - Called by a variable trace on "unset socketRdState($connId)". -# - The variable relates to a Keep-Alive socket, which has been closed. -# - Cancels all pipelined responses. The requests have been sent, -# the responses have not yet been received. -# - This is a hard cancel that ends each transaction with error status, -# and closes the connection. Do not use it if you want to replay failed -# transactions. -# - N.B. Always delete ::http::socketRdState($connId) before deleting -# ::http::socketRdQueue($connId), or this command will do nothing. -# -# Arguments -# As for a trace command on a variable. - -proc http::CancelReadPipeline {name1 connId op} { - variable socketRdQueue - ##Log CancelReadPipeline $name1 $connId $op - if {[info exists socketRdQueue($connId)]} { - set msg {the connection was closed by CancelReadPipeline} - foreach token $socketRdQueue($connId) { - set tk [namespace tail $token] - Log ^X$tk end of response "($msg)" - token $token - set ${token}(status) eof - Finish $token ;#$msg - } - set socketRdQueue($connId) {} - } - return -} - -# http::CancelWritePipeline -# -# Cancel queued events on a closing "Keep-Alive" socket. -# -# - Called by a variable trace on "unset socketWrState($connId)". -# - The variable relates to a Keep-Alive socket, which has been closed. -# - In pipelined or nonpipeline case: cancels all queued requests. The -# requests have not yet been sent, the responses are not due. -# - This is a hard cancel that ends each transaction with error status, -# and closes the connection. Do not use it if you want to replay failed -# transactions. -# - N.B. Always delete ::http::socketWrState($connId) before deleting -# ::http::socketWrQueue($connId), or this command will do nothing. -# -# Arguments -# As for a trace command on a variable. - -proc http::CancelWritePipeline {name1 connId op} { - variable socketWrQueue - - ##Log CancelWritePipeline $name1 $connId $op - if {[info exists socketWrQueue($connId)]} { - set msg {the connection was closed by CancelWritePipeline} - foreach token $socketWrQueue($connId) { - set tk [namespace tail $token] - Log ^X$tk end of response "($msg)" - token $token - set ${token}(status) eof - Finish $token ;#$msg - } - set socketWrQueue($connId) {} - } - return -} - -# http::ReplayIfDead -- -# -# - A query on a re-used persistent socket failed at the earliest opportunity, -# because the socket had been closed by the server. Keep the token, tidy up, -# and try to connect on a fresh socket. -# - The connection is monitored for eof by the command http::CheckEof. Thus -# http::ReplayIfDead is needed only when a server event (half-closing an -# apparently idle connection), and a client event (sending a request) occur at -# almost the same time, and neither client nor server detects the other's -# action before performing its own (an "asynchronous close event"). -# - To simplify testing of http::ReplayIfDead, set TEST_EOF 1 in -# http::KeepSocket, and then http::ReplayIfDead will be called if http::geturl -# is called at any time after the server timeout. -# -# Arguments: -# token Connection token. -# -# Side Effects: -# Use the same token, but try to open a new socket. - -proc http::ReplayIfDead {token doing} { - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - variable $token - upvar 0 $token state - - Log running http::ReplayIfDead for $token $doing - - # 1. Merge the tokens for transactions in flight, the read (response) queue, - # and the write (request) queue. - - set InFlightR {} - set InFlightW {} - - # Obtain the tokens for transactions in flight. - if {$state(-pipeline)} { - # Two transactions may be in flight. The "read" transaction was first. - # It is unlikely that the server would close the socket if a response - # was pending; however, an earlier request (as well as the present - # request) may have been sent and ignored if the socket was half-closed - # by the server. - - if { [info exists socketRdState($state(socketinfo))] - && ($socketRdState($state(socketinfo)) ne "Rready") - } { - lappend InFlightR $socketRdState($state(socketinfo)) - } elseif {($doing eq "read")} { - lappend InFlightR $token - } - - if { [info exists socketWrState($state(socketinfo))] - && $socketWrState($state(socketinfo)) ni {Wready peNding} - } { - lappend InFlightW $socketWrState($state(socketinfo)) - } elseif {($doing eq "write")} { - lappend InFlightW $token - } - - # Report any inconsistency of $token with socket*state. - if { ($doing eq "read") - && [info exists socketRdState($state(socketinfo))] - && ($token ne $socketRdState($state(socketinfo))) - } { - Log WARNING - ReplayIfDead pipelined token $token $doing \ - ne socketRdState($state(socketinfo)) \ - $socketRdState($state(socketinfo)) - - } elseif { - ($doing eq "write") - && [info exists socketWrState($state(socketinfo))] - && ($token ne $socketWrState($state(socketinfo))) - } { - Log WARNING - ReplayIfDead pipelined token $token $doing \ - ne socketWrState($state(socketinfo)) \ - $socketWrState($state(socketinfo)) - } - } else { - # One transaction should be in flight. - # socketRdState, socketWrQueue are used. - # socketRdQueue should be empty. - - # Report any inconsistency of $token with socket*state. - if {$token ne $socketRdState($state(socketinfo))} { - Log WARNING - ReplayIfDead nonpipeline token $token $doing \ - ne socketRdState($state(socketinfo)) \ - $socketRdState($state(socketinfo)) - } - - # Report the inconsistency that socketRdQueue is non-empty. - if { [info exists socketRdQueue($state(socketinfo))] - && ($socketRdQueue($state(socketinfo)) ne {}) - } { - Log WARNING - ReplayIfDead nonpipeline token $token $doing \ - has read queue socketRdQueue($state(socketinfo)) \ - $socketRdQueue($state(socketinfo)) ne {} - } - - lappend InFlightW $socketRdState($state(socketinfo)) - set socketRdQueue($state(socketinfo)) {} - } - - set newQueue {} - lappend newQueue {*}$InFlightR - lappend newQueue {*}$socketRdQueue($state(socketinfo)) - lappend newQueue {*}$InFlightW - lappend newQueue {*}$socketWrQueue($state(socketinfo)) - - - # 2. Tidy up token. This is a cut-down form of Finish/CloseSocket. - # Do not change state(status). - # No need to after cancel state(after) - either this is done in - # ReplayCore/ReInit, or Finish is called. - - catch {close $state(sock)} - Unset $state(socketinfo) - - # 2a. Tidy the tokens in the queues - this is done in ReplayCore/ReInit. - # - Transactions, if any, that are awaiting responses cannot be completed. - # They are listed for re-sending in newQueue. - # - All tokens are preserved for re-use by ReplayCore, and their variables - # will be re-initialised by calls to ReInit. - # - The relevant element of socketMapping, socketRdState, socketWrState, - # socketRdQueue, socketWrQueue, socketClosing, socketPlayCmd will be set - # to new values in ReplayCore. - - ReplayCore $newQueue - return -} - -# http::ReplayIfClose -- -# -# A request on a socket that was previously "Connection: keep-alive" has -# received a "Connection: close" response header. The server supplies -# that response correctly, but any later requests already queued on this -# connection will be lost when the socket closes. -# -# This command takes arguments that represent the socketWrState, -# socketRdQueue and socketWrQueue for this connection. The socketRdState -# is not needed because the server responds in full to the request that -# received the "Connection: close" response header. -# -# Existing request tokens $token (::http::$n) are preserved. The caller -# will be unaware that the request was processed this way. - -proc http::ReplayIfClose {Wstate Rqueue Wqueue} { - Log running http::ReplayIfClose for $Wstate $Rqueue $Wqueue - - if {$Wstate in $Rqueue || $Wstate in $Wqueue} { - Log WARNING duplicate token in http::ReplayIfClose - token $Wstate - set Wstate Wready - } - - # 1. Create newQueue - set InFlightW {} - if {$Wstate ni {Wready peNding}} { - lappend InFlightW $Wstate - } - ##Log $Rqueue -- $InFlightW -- $Wqueue - set newQueue {} - lappend newQueue {*}$Rqueue - lappend newQueue {*}$InFlightW - lappend newQueue {*}$Wqueue - - # 2. Cleanup - none needed, done by the caller. - - ReplayCore $newQueue - return -} - -# http::ReInit -- -# -# Command to restore a token's state to a condition that -# makes it ready to replay a request. -# -# Command http::geturl stores extra state in state(tmp*) so -# we don't need to do the argument processing again. -# -# The caller must: -# - Set state(reusing) and state(sock) to their new values after calling -# this command. -# - Unset state(tmpState), state(tmpOpenCmd) if future calls to ReplayCore -# or ReInit are inappropriate for this token. Typically only one retry -# is allowed. -# The caller may also unset state(tmpConnArgs) if this value (and the -# token) will be used immediately. The value is needed by tokens that -# will be stored in a queue. -# -# Arguments: -# token Connection token. -# -# Return Value: (boolean) true iff the re-initialisation was successful. - -proc http::ReInit {token} { - variable $token - upvar 0 $token state - - if {!( - [info exists state(tmpState)] - && [info exists state(tmpOpenCmd)] - && [info exists state(tmpConnArgs)] - ) - } { - Log FAILED in http::ReInit via ReplayCore - NO tmp vars for $token - return 0 - } - - if {[info exists state(after)]} { - after cancel $state(after) - unset state(after) - } - if {[info exists state(socketcoro)]} { - Log $token Cancel socket after-idle event (ReInit) - after cancel $state(socketcoro) - unset state(socketcoro) - } - - # Don't alter state(status) - this would trigger http::wait if it is in use. - set tmpState $state(tmpState) - set tmpOpenCmd $state(tmpOpenCmd) - set tmpConnArgs $state(tmpConnArgs) - foreach name [array names state] { - if {$name ne "status"} { - unset state($name) - } - } - - # Don't alter state(status). - # Restore state(tmp*) - the caller may decide to unset them. - # Restore state(tmpConnArgs) which is needed for connection. - # state(tmpState), state(tmpOpenCmd) are needed only for retries. - - dict unset tmpState status - array set state $tmpState - set state(tmpState) $tmpState - set state(tmpOpenCmd) $tmpOpenCmd - set state(tmpConnArgs) $tmpConnArgs - - return 1 -} - -# http::ReplayCore -- -# -# Command to replay a list of requests, using existing connection tokens. -# -# Abstracted from http::geturl which stores extra state in state(tmp*) so -# we don't need to do the argument processing again. -# -# Arguments: -# newQueue List of connection tokens. -# -# Side Effects: -# Use existing tokens, but try to open a new socket. - -proc http::ReplayCore {newQueue} { - variable TmpSockCounter - - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - if {[llength $newQueue] == 0} { - # Nothing to do. - return - } - - ##Log running ReplayCore for {*}$newQueue - set newToken [lindex $newQueue 0] - set newQueue [lrange $newQueue 1 end] - - # 3. Use newToken, and restore its values of state(*). Do not restore - # elements tmp* - we try again only once. - - set token $newToken - variable $token - upvar 0 $token state - - if {![ReInit $token]} { - Log FAILED in http::ReplayCore - NO tmp vars - Log ReplayCore reject $token - Finish $token {cannot send this request again} - return - } - - set tmpState $state(tmpState) - set tmpOpenCmd $state(tmpOpenCmd) - set tmpConnArgs $state(tmpConnArgs) - unset state(tmpState) - unset state(tmpOpenCmd) - unset state(tmpConnArgs) - - set state(reusing) 0 - set state(ReusingPlaceholder) 0 - set state(alreadyQueued) 0 - Log ReplayCore replay $token - - # Give the socket a placeholder name before it is created. - set sock HTTP_PLACEHOLDER_[incr TmpSockCounter] - set state(sock) $sock - - # Move the $newQueue into the placeholder socket's socketPhQueue. - set socketPhQueue($sock) {} - foreach tok $newQueue { - if {[ReInit $tok]} { - set ${tok}(reusing) 1 - set ${tok}(sock) $sock - lappend socketPhQueue($sock) $tok - Log ReplayCore replay $tok - } else { - Log ReplayCore reject $tok - set ${tok}(reusing) 1 - set ${tok}(sock) NONE - Finish $tok {cannot send this request again} - } - } - - AsyncTransaction $token - - return -} - -# Data access functions: -# Data - the URL data -# Status - the transaction status: ok, reset, eof, timeout, error -# Code - the HTTP transaction code, e.g., 200 -# Size - the size of the URL data - -proc http::responseBody {token} { - variable $token - upvar 0 $token state - return $state(body) -} -proc http::status {token} { - if {![info exists $token]} { - return "error" - } - variable $token - upvar 0 $token state - return $state(status) -} -proc http::responseLine {token} { - variable $token - upvar 0 $token state - return $state(http) -} -proc http::requestLine {token} { - variable $token - upvar 0 $token state - return $state(requestLine) -} -proc http::responseCode {token} { - variable $token - upvar 0 $token state - if {[regexp {[0-9]{3}} $state(http) numeric_code]} { - return $numeric_code - } else { - return $state(http) - } -} -proc http::size {token} { - variable $token - upvar 0 $token state - return $state(currentsize) -} -proc http::requestHeaders {token args} { - set lenny [llength $args] - if {$lenny > 1} { - return -code error {usage: ::http::requestHeaders token ?headerName?} - } else { - return [Meta $token request {*}$args] - } -} -proc http::responseHeaders {token args} { - set lenny [llength $args] - if {$lenny > 1} { - return -code error {usage: ::http::responseHeaders token ?headerName?} - } else { - return [Meta $token response {*}$args] - } -} -proc http::requestHeaderValue {token header} { - Meta $token request $header VALUE -} -proc http::responseHeaderValue {token header} { - Meta $token response $header VALUE -} -proc http::Meta {token who args} { - variable $token - upvar 0 $token state - - if {$who eq {request}} { - set whom requestHeaders - } elseif {$who eq {response}} { - set whom meta - } else { - return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??} - } - - set header [string tolower [lindex $args 0]] - set how [string tolower [lindex $args 1]] - set lenny [llength $args] - if {$lenny == 0} { - return $state($whom) - } elseif {($lenny > 2) || (($lenny == 2) && ($how ne {value}))} { - return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??} - } else { - set result {} - set combined {} - foreach {key value} $state($whom) { - if {$key eq $header} { - lappend result $key $value - append combined $value {, } - } - } - if {$lenny == 1} { - return $result - } else { - return [string range $combined 0 end-2] - } - } -} - - -# ------------------------------------------------------------------------------ -# Proc http::responseInfo -# ------------------------------------------------------------------------------ -# Command to return a dictionary of the most useful metadata of a HTTP -# response. -# -# Arguments: -# token - connection token (name of an array) -# -# Return Value: a dict. See man page http(n) for a description of each item. -# ------------------------------------------------------------------------------ - -proc http::responseInfo {token} { - variable $token - upvar 0 $token state - set result {} - foreach {key origin name} { - stage STATE state - status STATE status - responseCode STATE responseCode - reasonPhrase STATE reasonPhrase - contentType STATE type - binary STATE binary - redirection RESP location - upgrade STATE upgrade - error ERROR - - postError STATE posterror - method STATE method - charset STATE charset - compression STATE coding - httpRequest STATE -protocol - httpResponse STATE httpResponse - url STATE url - connectionRequest REQ connection - connectionResponse RESP connection - connectionActual STATE connection - transferEncoding STATE transfer - totalPost STATE querylength - currentPost STATE queryoffset - totalSize STATE totalsize - currentSize STATE currentsize - proxyUsed STATE proxyUsed - } { - if {$origin eq {STATE}} { - if {[info exists state($name)]} { - dict set result $key $state($name) - } else { - # Should never come here - dict set result $key {} - } - } elseif {$origin eq {REQ}} { - dict set result $key [requestHeaderValue $token $name] - } elseif {$origin eq {RESP}} { - dict set result $key [responseHeaderValue $token $name] - } elseif {$origin eq {ERROR}} { - # Don't flood the dict with data. The command ::http::error is - # available. - if {[info exists state(error)]} { - set msg [lindex $state(error) 0] - } else { - set msg {} - } - dict set result $key $msg - } else { - # Should never come here - dict set result $key {} - } - } - return $result -} -proc http::error {token} { - variable $token - upvar 0 $token state - if {[info exists state(error)]} { - return $state(error) - } - return -} -proc http::postError {token} { - variable $token - upvar 0 $token state - if {[info exists state(postErrorFull)]} { - return $state(postErrorFull) - } - return -} - -# http::cleanup -# -# Garbage collect the state associated with a transaction -# -# Arguments -# token The token returned from http::geturl -# -# Side Effects -# Unsets the state array. - -proc http::cleanup {token} { - variable $token - upvar 0 $token state - if {[info commands ${token}--EventCoroutine] ne {}} { - rename ${token}--EventCoroutine {} - } - if {[info commands ${token}--SocketCoroutine] ne {}} { - rename ${token}--SocketCoroutine {} - } - if {[info exists state(after)]} { - after cancel $state(after) - unset state(after) - } - if {[info exists state(socketcoro)]} { - Log $token Cancel socket after-idle event (cleanup) - after cancel $state(socketcoro) - unset state(socketcoro) - } - if {[info exists state]} { - unset state - } - return -} - -# http::Connect -# -# This callback is made when an asynchronous connection completes. -# -# Arguments -# token The token returned from http::geturl -# -# Side Effects -# Sets the status of the connection, which unblocks -# the waiting geturl call - -proc http::Connect {token proto phost srvurl} { - variable $token - upvar 0 $token state - set tk [namespace tail $token] - - if {[catch {eof $state(sock)} tmp] || $tmp} { - set err "due to unexpected EOF" - } elseif {[set err [fconfigure $state(sock) -error]] ne ""} { - # set err is done in test - } else { - # All OK - set state(state) connecting - fileevent $state(sock) writable {} - ::http::Connected $token $proto $phost $srvurl - return - } - - # Error cases. - Log "WARNING - if testing, pay special attention to this\ - case (GJ) which is seldom executed - token $token" - if {[info exists state(reusing)] && $state(reusing)} { - # The socket was closed at the server end, and closed at - # this end by http::CheckEof. - if {[TestForReplay $token write $err b]} { - return - } - - # else: - # This is NOT a persistent socket that has been closed since its - # last use. - # If any other requests are in flight or pipelined/queued, they will - # be discarded. - } - Finish $token "connect failed: $err" - return -} - -# http::Write -# -# Write POST query data to the socket -# -# Arguments -# token The token for the connection -# -# Side Effects -# Write the socket and handle callbacks. - -proc http::Write {token} { - variable http - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - variable $token - upvar 0 $token state - set tk [namespace tail $token] - set sock $state(sock) - - # Output a block. Tcl will buffer this if the socket blocks - set done 0 - if {[catch { - # Catch I/O errors on dead sockets - - if {[info exists state(-query)]} { - # Chop up large query strings so queryprogress callback can give - # smooth feedback. - if { $state(queryoffset) + $state(-queryblocksize) - >= $state(querylength) - } { - # This will be the last puts for the request-body. - if { (![catch {fileevent $sock readable} binding]) - && ($binding eq [list http::CheckEof $sock]) - } { - # Remove the "fileevent readable" binding of an idle - # persistent socket to http::CheckEof. We can no longer - # treat bytes received as junk. The server might still time - # out and half-close the socket if it has not yet received - # the first "puts". - fileevent $sock readable {} - } - } - puts -nonewline $sock \ - [string range $state(-query) $state(queryoffset) \ - [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]] - incr state(queryoffset) $state(-queryblocksize) - if {$state(queryoffset) >= $state(querylength)} { - set state(queryoffset) $state(querylength) - set done 1 - } - } else { - # Copy blocks from the query channel - - set outStr [read $state(-querychannel) $state(-queryblocksize)] - if {[eof $state(-querychannel)]} { - # This will be the last puts for the request-body. - if { (![catch {fileevent $sock readable} binding]) - && ($binding eq [list http::CheckEof $sock]) - } { - # Remove the "fileevent readable" binding of an idle - # persistent socket to http::CheckEof. We can no longer - # treat bytes received as junk. The server might still time - # out and half-close the socket if it has not yet received - # the first "puts". - fileevent $sock readable {} - } - } - puts -nonewline $sock $outStr - incr state(queryoffset) [string length $outStr] - if {[eof $state(-querychannel)]} { - set done 1 - } - } - } err opts]} { - # Do not call Finish here, but instead let the read half of the socket - # process whatever server reply there is to get. - set state(posterror) $err - set info [dict get $opts -errorinfo] - set code [dict get $opts -code] - set state(postErrorFull) [list $err $info $code] - set done 1 - } - - if {$done} { - catch {flush $sock} - fileevent $sock writable {} - Log ^C$tk end sending request - token $token - # End of writing (POST method). The request has been sent. - - DoneRequest $token - } - - # Callback to the client after we've completely handled everything. - - if {[string length $state(-queryprogress)]} { - namespace eval :: $state(-queryprogress) \ - [list $token $state(querylength) $state(queryoffset)] - } - return -} - -# http::Event -# -# Handle input on the socket. This command is the core of -# the coroutine commands ${token}--EventCoroutine that are -# bound to "fileevent $sock readable" and process input. -# -# Arguments -# sock The socket receiving input. -# token The token returned from http::geturl -# -# Side Effects -# Read the socket and handle callbacks. - -proc http::Event {sock token} { - variable http - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketPhQueue - variable socketClosing - variable socketPlayCmd - variable socketCoEvent - variable socketProxyId - - variable $token - upvar 0 $token state - set tk [namespace tail $token] - while 1 { - yield - ##Log Event call - token $token - - if {![info exists state]} { - Log "Event $sock with invalid token '$token' - remote close?" - if {!([catch {eof $sock} tmp] || $tmp)} { - if {[set d [read $sock]] ne ""} { - Log "WARNING: additional data left on closed socket\ - - token $token" - } else { - } - } else { - } - Log ^X$tk end of response (token error) - token $token - CloseSocket $sock - return - } else { - } - if {$state(state) eq "connecting"} { - ##Log - connecting - token $token - if { $state(reusing) - && $state(-pipeline) - && ($state(-timeout) > 0) - && (![info exists state(after)]) - } { - set state(after) [after $state(-timeout) \ - [list http::reset $token timeout]] - } else { - } - - if {[catch {gets $sock state(http)} nsl]} { - Log "WARNING - if testing, pay special attention to this\ - case (GK) which is seldom executed - token $token" - if {[info exists state(reusing)] && $state(reusing)} { - # The socket was closed at the server end, and closed at - # this end by http::CheckEof. - - if {[TestForReplay $token read $nsl c]} { - return - } else { - } - # else: - # This is NOT a persistent socket that has been closed since - # its last use. - # If any other requests are in flight or pipelined/queued, - # they will be discarded. - } else { - # https handshake errors come here, for - # Tcl 8.7 with http::SecureProxyConnect. - set msg [registerError $sock] - registerError $sock {} - if {$msg eq {}} { - set msg $nsl - } - Log ^X$tk end of response (error) - token $token - Finish $token $msg - return - } - } elseif {$nsl >= 0} { - ##Log - connecting 1 - token $token - set state(state) "header" - } elseif { ([catch {eof $sock} tmp] || $tmp) - && [info exists state(reusing)] - && $state(reusing) - } { - # The socket was closed at the server end, and we didn't notice. - # This is the first read - where the closure is usually first - # detected. - - if {[TestForReplay $token read {} d]} { - return - } else { - } - - # else: - # This is NOT a persistent socket that has been closed since its - # last use. - # If any other requests are in flight or pipelined/queued, they - # will be discarded. - } else { - } - } elseif {$state(state) eq "header"} { - if {[catch {gets $sock line} nhl]} { - ##Log header failed - token $token - Log ^X$tk end of response (error) - token $token - Finish $token $nhl - return - } elseif {$nhl == 0} { - ##Log header done - token $token - Log ^E$tk end of response headers - token $token - # We have now read all headers - # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3 - if { ($state(http) == "") - || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100) - } { - set state(state) "connecting" - continue - # This was a "return" in the pre-coroutine code. - } else { - } - - # We have $state(http) so let's split it into its components. - if {[regexp {^HTTP/(\S+) ([0-9]{3}) (.*)$} $state(http) \ - -> httpResponse responseCode reasonPhrase] - } { - set state(httpResponse) $httpResponse - set state(responseCode) $responseCode - set state(reasonPhrase) $reasonPhrase - } else { - set state(httpResponse) $state(http) - set state(responseCode) $state(http) - set state(reasonPhrase) $state(http) - } - - if { ([info exists state(connection)]) - && ([info exists socketMapping($state(socketinfo))]) - && ("keep-alive" in $state(connection)) - && ($state(-keepalive)) - && (!$state(reusing)) - && ($state(-pipeline)) - } { - # Response headers received for first request on a - # persistent socket. Now ready for pipelined writes (if - # any). - # Previous value is $token. It cannot be "pending". - set socketWrState($state(socketinfo)) Wready - http::NextPipelinedWrite $token - } else { - } - - # Once a "close" has been signaled, the client MUST NOT send any - # more requests on that connection. - # - # If either the client or the server sends the "close" token in - # the Connection header, that request becomes the last one for - # the connection. - - if { ([info exists state(connection)]) - && ([info exists socketMapping($state(socketinfo))]) - && ("close" in $state(connection)) - && ($state(-keepalive)) - } { - # The server warns that it will close the socket after this - # response. - ##Log WARNING - socket will close after response for $token - # Prepare data for a call to ReplayIfClose. - Log $token socket will close after this transaction - # 1. Cancel socket-assignment coro events that have not yet - # launched, and add the tokens to the write queue. - if {[info exists socketCoEvent($state(socketinfo))]} { - foreach {tok can} $socketCoEvent($state(socketinfo)) { - lappend socketWrQueue($state(socketinfo)) $tok - unset -nocomplain ${tok}(socketcoro) - after cancel $can - Log $tok Cancel socket after-idle event (Event) - Log Move $tok from socketCoEvent to socketWrQueue and cancel its after idle coro - } - set socketCoEvent($state(socketinfo)) {} - } else { - } - - if { ($socketRdQueue($state(socketinfo)) ne {}) - || ($socketWrQueue($state(socketinfo)) ne {}) - || ($socketWrState($state(socketinfo)) ni - [list Wready peNding $token]) - } { - set InFlightW $socketWrState($state(socketinfo)) - if {$InFlightW in [list Wready peNding $token]} { - set InFlightW Wready - } else { - set msg "token ${InFlightW} is InFlightW" - ##Log $msg - token $token - } - set socketPlayCmd($state(socketinfo)) \ - [list ReplayIfClose $InFlightW \ - $socketRdQueue($state(socketinfo)) \ - $socketWrQueue($state(socketinfo))] - - # - All tokens are preserved for re-use by ReplayCore. - # - Queues are preserved in case of Finish with error, - # but are not used for anything else because - # socketClosing(*) is set below. - # - Cancel the state(after) timeout events. - foreach tokenVal $socketRdQueue($state(socketinfo)) { - if {[info exists ${tokenVal}(after)]} { - after cancel [set ${tokenVal}(after)] - unset ${tokenVal}(after) - } else { - } - # Tokens in the read queue have no (socketcoro) to - # cancel. - } - } else { - set socketPlayCmd($state(socketinfo)) \ - {ReplayIfClose Wready {} {}} - } - - # Do not allow further connections on this socket (but - # geturl can add new requests to the replay). - set socketClosing($state(socketinfo)) 1 - } else { - } - - set state(state) body - - # According to - # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection - # any comma-separated "Connection:" list implies keep-alive, but I - # don't see this in the RFC so we'll play safe and - # scan any list for "close". - # Done here to support combining duplicate header field's values. - if { [info exists state(connection)] - && ("close" ni $state(connection)) - && ("keep-alive" ni $state(connection)) - } { - lappend state(connection) "keep-alive" - } else { - } - - # If doing a HEAD, then we won't get any body - if {$state(-validate)} { - Log ^F$tk end of response for HEAD request - token $token - set state(state) complete - Eot $token - return - } elseif { - ($state(method) eq {CONNECT}) - && [string is integer -strict $state(responseCode)] - && ($state(responseCode) >= 200) - && ($state(responseCode) < 300) - } { - # A successful CONNECT response has no body. - # (An unsuccessful CONNECT has headers and body.) - # The code below is abstracted from Eot/Finish, but - # keeps the socket open. - catch {fileevent $state(sock) readable {}} - catch {fileevent $state(sock) writable {}} - set state(state) complete - set state(status) ok - if {[info commands ${token}--EventCoroutine] ne {}} { - rename ${token}--EventCoroutine {} - } - if {[info commands ${token}--SocketCoroutine] ne {}} { - rename ${token}--SocketCoroutine {} - } - if {[info exists state(socketcoro)]} { - Log $token Cancel socket after-idle event (Finish) - after cancel $state(socketcoro) - unset state(socketcoro) - } - if {[info exists state(after)]} { - after cancel $state(after) - unset state(after) - } - if { [info exists state(-command)] - && (![info exists state(done-command-cb)]) - } { - set state(done-command-cb) yes - if {[catch {namespace eval :: $state(-command) $token} err]} { - set state(error) [list $err $errorInfo $errorCode] - set state(status) error - } - } - return - } else { - } - - # - For non-chunked transfer we may have no body - in this case - # we may get no further file event if the connection doesn't - # close and no more data is sent. We can tell and must finish - # up now - not later - the alternative would be to wait until - # the server times out. - # - In this case, the server has NOT told the client it will - # close the connection, AND it has NOT indicated the resource - # length EITHER by setting the Content-Length (totalsize) OR - # by using chunked Transfer-Encoding. - # - Do not worry here about the case (Connection: close) because - # the server should close the connection. - # - IF (NOT Connection: close) AND (NOT chunked encoding) AND - # (totalsize == 0). - - if { (!( [info exists state(connection)] - && ("close" in $state(connection)) - ) - ) - && ($state(transfer) eq {}) - && ($state(totalsize) == 0) - } { - set msg {body size is 0 and no events likely - complete} - Log "$msg - token $token" - set msg {(length unknown, set to 0)} - Log ^F$tk end of response body {*}$msg - token $token - set state(state) complete - Eot $token - return - } else { - } - - # We have to use binary translation to count bytes properly. - lassign [fconfigure $sock -translation] trRead trWrite - fconfigure $sock -translation [list binary $trWrite] - - if { - $state(-binary) || [IsBinaryContentType $state(type)] - } { - # Turn off conversions for non-text data. - set state(binary) 1 - } else { - } - if {[info exists state(-channel)]} { - if {$state(binary) || [llength [ContentEncoding $token]]} { - fconfigure $state(-channel) -translation binary - } else { - } - if {![info exists state(-handler)]} { - # Initiate a sequence of background fcopies. - fileevent $sock readable {} - rename ${token}--EventCoroutine {} - CopyStart $sock $token - return - } else { - } - } else { - } - } elseif {$nhl > 0} { - # Process header lines. - ##Log header - token $token - $line - if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { - set key [string tolower $key] - switch -- $key { - content-type { - set state(type) [string trim [string tolower $value]] - # Grab the optional charset information. - if {[regexp -nocase \ - {charset\s*=\s*\"((?:[^""]|\\\")*)\"} \ - $state(type) -> cs]} { - set state(charset) [string map {{\"} \"} $cs] - } else { - regexp -nocase {charset\s*=\s*(\S+?);?} \ - $state(type) -> state(charset) - } - } - content-length { - set state(totalsize) [string trim $value] - } - content-encoding { - set state(coding) [string trim $value] - } - transfer-encoding { - set state(transfer) \ - [string trim [string tolower $value]] - } - proxy-connection - - connection { - # RFC 7230 Section 6.1 states that a comma-separated - # list is an acceptable value. - if {![info exists state(connectionRespFlag)]} { - # This is the first "Connection" response header. - # Scrub the earlier value set by iniitialisation. - set state(connectionRespFlag) {} - set state(connection) {} - } - foreach el [SplitCommaSeparatedFieldValue $value] { - lappend state(connection) [string tolower $el] - } - } - upgrade { - set state(upgrade) [string trim $value] - } - set-cookie { - if {$http(-cookiejar) ne ""} { - ParseCookie $token [string trim $value] - } else { - } - } - } - lappend state(meta) $key [string trim $value] - } else { - } - } else { - } - } else { - # Now reading body - ##Log body - token $token - if {[catch { - if {[info exists state(-handler)]} { - set n [namespace eval :: $state(-handler) [list $sock $token]] - ##Log handler $n - token $token - # N.B. the protocol has been set to 1.0 because the -handler - # logic is not expected to handle chunked encoding. - # FIXME Allow -handler with 1.1 on dechunked stacked chan. - if {$state(totalsize) == 0} { - # We know the transfer is complete only when the server - # closes the connection - i.e. eof is not an error. - set state(state) complete - } else { - } - if {![string is integer -strict $n]} { - if 1 { - # Do not tolerate bad -handler - fail with error - # status. - set msg {the -handler command for http::geturl must\ - return an integer (the number of bytes\ - read)} - Log ^X$tk end of response (handler error) -\ - token $token - Eot $token $msg - } else { - # Tolerate the bad -handler, and continue. The - # penalty: - # (a) Because the handler returns nonsense, we know - # the transfer is complete only when the server - # closes the connection - i.e. eof is not an - # error. - # (b) http::size will not be accurate. - # (c) The transaction is already downgraded to 1.0 - # to avoid chunked transfer encoding. It MUST - # also be forced to "Connection: close" or the - # HTTP/1.0 equivalent; or it MUST fail (as - # above) if the server sends - # "Connection: keep-alive" or the HTTP/1.0 - # equivalent. - set n 0 - set state(state) complete - } - } else { - } - } elseif {[info exists state(transfer_final)]} { - # This code forgives EOF in place of the final CRLF. - set line [GetTextLine $sock] - set n [string length $line] - set state(state) complete - if {$n > 0} { - # - HTTP trailers (late response headers) are permitted - # by Chunked Transfer-Encoding, and can be safely - # ignored. - # - Do not count these bytes in the total received for - # the response body. - Log "trailer of $n bytes after final chunk -\ - token $token" - append state(transfer_final) $line - set n 0 - } else { - Log ^F$tk end of response body (chunked) - token $token - Log "final chunk part - token $token" - Eot $token - } - } elseif { [info exists state(transfer)] - && ($state(transfer) eq "chunked") - } { - ##Log chunked - token $token - set size 0 - set hexLenChunk [GetTextLine $sock] - #set ntl [string length $hexLenChunk] - if {[string trim $hexLenChunk] ne ""} { - scan $hexLenChunk %x size - if {$size != 0} { - ##Log chunk-measure $size - token $token - set chunk [BlockingRead $sock $size] - set n [string length $chunk] - if {$n >= 0} { - append state(body) $chunk - incr state(log_size) [string length $chunk] - ##Log chunk $n cumul $state(log_size) -\ - token $token - } else { - } - if {$size != [string length $chunk]} { - Log "WARNING: mis-sized chunk:\ - was [string length $chunk], should be\ - $size - token $token" - set n 0 - set state(connection) close - Log ^X$tk end of response (chunk error) \ - - token $token - set msg {error in chunked encoding - fetch\ - terminated} - Eot $token $msg - } else { - } - # CRLF that follows chunk. - # If eof, this is handled at the end of this proc. - GetTextLine $sock - } else { - set n 0 - set state(transfer_final) {} - } - } else { - # Line expected to hold chunk length is empty, or eof. - ##Log bad-chunk-measure - token $token - set n 0 - set state(connection) close - Log ^X$tk end of response (chunk error) - token $token - Eot $token {error in chunked encoding -\ - fetch terminated} - } - } else { - ##Log unchunked - token $token - if {$state(totalsize) == 0} { - # We know the transfer is complete only when the server - # closes the connection. - set state(state) complete - set reqSize $state(-blocksize) - } else { - # Ask for the whole of the unserved response-body. - # This works around a problem with a tls::socket - for - # https in keep-alive mode, and a request for - # $state(-blocksize) bytes, the last part of the - # resource does not get read until the server times out. - set reqSize [expr { $state(totalsize) - - $state(currentsize)}] - - # The workaround fails if reqSize is - # capped at $state(-blocksize). - # set reqSize [expr {min($reqSize, $state(-blocksize))}] - } - set c $state(currentsize) - set t $state(totalsize) - ##Log non-chunk currentsize $c of totalsize $t -\ - token $token - set block [read $sock $reqSize] - set n [string length $block] - if {$n >= 0} { - append state(body) $block - ##Log non-chunk [string length $state(body)] -\ - token $token - } else { - } - } - # This calculation uses n from the -handler, chunked, or - # unchunked case as appropriate. - if {[info exists state]} { - if {$n >= 0} { - incr state(currentsize) $n - set c $state(currentsize) - set t $state(totalsize) - ##Log another $n currentsize $c totalsize $t -\ - token $token - } else { - } - # If Content-Length - check for end of data. - if { - ($state(totalsize) > 0) - && ($state(currentsize) >= $state(totalsize)) - } { - Log ^F$tk end of response body (unchunked) -\ - token $token - set state(state) complete - Eot $token - } else { - } - } else { - } - } err]} { - Log ^X$tk end of response (error ${err}) - token $token - Finish $token $err - return - } else { - if {[info exists state(-progress)]} { - namespace eval :: $state(-progress) \ - [list $token $state(totalsize) $state(currentsize)] - } else { - } - } - } - - # catch as an Eot above may have closed the socket already - # $state(state) may be connecting, header, body, or complete - if {(![catch {eof $sock} eof]) && $eof} { - # [eof sock] succeeded and the result was 1 - ##Log eof - token $token - if {[info exists $token]} { - set state(connection) close - if {$state(state) eq "complete"} { - # This includes all cases in which the transaction - # can be completed by eof. - # The value "complete" is set only in http::Event, and it is - # used only in the test above. - Log ^F$tk end of response body (unchunked, eof) -\ - token $token - Eot $token - } else { - # Premature eof. - Log ^X$tk end of response (unexpected eof) - token $token - Eot $token eof - } - } else { - # open connection closed on a token that has been cleaned up. - Log ^X$tk end of response (token error) - token $token - CloseSocket $sock - } - } else { - # EITHER [eof sock] failed - presumed done by Eot - # OR [eof sock] succeeded and the result was 0 - } - } - return -} - -# http::TestForReplay -# -# Command called if eof is discovered when a socket is first used for a -# new transaction. Typically this occurs if a persistent socket is used -# after a period of idleness and the server has half-closed the socket. -# -# token - the connection token returned by http::geturl -# doing - "read" or "write" -# err - error message, if any -# caller - code to identify the caller - used only in logging -# -# Return Value: boolean, true iff the command calls http::ReplayIfDead. - -proc http::TestForReplay {token doing err caller} { - variable http - variable $token - upvar 0 $token state - set tk [namespace tail $token] - if {$doing eq "read"} { - set code Q - set action response - set ing reading - } else { - set code P - set action request - set ing writing - } - - if {$err eq {}} { - set err "detect eof when $ing (server timed out?)" - } - - if {$state(method) eq "POST" && !$http(-repost)} { - # No Replay. - # The present transaction will end when Finish is called. - # That call to Finish will abort any other transactions - # currently in the write queue. - # For calls from http::Event this occurs when execution - # reaches the code block at the end of that proc. - set msg {no retry for POST with http::config -repost 0} - Log reusing socket failed "($caller)" - $msg - token $token - Log error - $err - token $token - Log ^X$tk end of $action (error) - token $token - return 0 - } else { - # Replay. - set msg {try a new socket} - Log reusing socket failed "($caller)" - $msg - token $token - Log error - $err - token $token - Log ^$code$tk Any unfinished (incl this one) failed - token $token - ReplayIfDead $token $doing - return 1 - } -} - -# http::IsBinaryContentType -- -# -# Determine if the content-type means that we should definitely transfer -# the data as binary. [Bug 838e99a76d] -# -# Arguments -# type The content-type of the data. -# -# Results: -# Boolean, true if we definitely should be binary. - -proc http::IsBinaryContentType {type} { - lassign [split [string tolower $type] "/;"] major minor - if {$major eq "text"} { - return false - } - # There's a bunch of XML-as-application-format things about. See RFC 3023 - # and so on. - if {$major eq "application"} { - set minor [string trimright $minor] - if {$minor in {"json" "xml" "xml-external-parsed-entity" "xml-dtd"}} { - return false - } - } - # Not just application/foobar+xml but also image/svg+xml, so let us not - # restrict things for now... - if {[string match "*+xml" $minor]} { - return false - } - return true -} - -proc http::ParseCookie {token value} { - variable http - variable CookieRE - variable $token - upvar 0 $token state - - if {![regexp $CookieRE $value -> cookiename cookieval opts]} { - # Bad cookie! No biscuit! - return - } - - # Convert the options into a list before feeding into the cookie store; - # ugly, but quite easy. - set realopts {hostonly 1 path / secure 0 httponly 0} - dict set realopts origin $state(host) - dict set realopts domain $state(host) - foreach option [split [regsub -all {;\s+} $opts \u0000] \u0000] { - regexp {^(.*?)(?:=(.*))?$} $option -> optname optval - switch -exact -- [string tolower $optname] { - expires { - if {[catch { - #Sun, 06 Nov 1994 08:49:37 GMT - dict set realopts expires \ - [clock scan $optval -format "%a, %d %b %Y %T %Z"] - }] && [catch { - # Google does this one - #Mon, 01-Jan-1990 00:00:00 GMT - dict set realopts expires \ - [clock scan $optval -format "%a, %d-%b-%Y %T %Z"] - }] && [catch { - # This is in the RFC, but it is also in the original - # Netscape cookie spec, now online at: - # - #Sunday, 06-Nov-94 08:49:37 GMT - dict set realopts expires \ - [clock scan $optval -format "%A, %d-%b-%y %T %Z"] - }]} {catch { - #Sun Nov 6 08:49:37 1994 - dict set realopts expires \ - [clock scan $optval -gmt 1 -format "%a %b %d %T %Y"] - }} - } - max-age { - # Normalize - if {[string is integer -strict $optval]} { - dict set realopts expires [expr {[clock seconds] + $optval}] - } - } - domain { - # From the domain-matches definition [RFC 2109, section 2]: - # Host A's name domain-matches host B's if [...] - # A is a FQDN string and has the form NB, where N is a - # non-empty name string, B has the form .B', and B' is a - # FQDN string. (So, x.y.com domain-matches .y.com but - # not y.com.) - if {$optval ne "" && ![string match *. $optval]} { - dict set realopts domain [string trimleft $optval "."] - dict set realopts hostonly [expr { - ! [string match .* $optval] - }] - } - } - path { - if {[string match /* $optval]} { - dict set realopts path $optval - } - } - secure - httponly { - dict set realopts [string tolower $optname] 1 - } - } - } - dict set realopts key $cookiename - dict set realopts value $cookieval - {*}$http(-cookiejar) storeCookie $realopts -} - -# http::GetTextLine -- -# -# Get one line with the stream in crlf mode. -# Used if Transfer-Encoding is chunked, to read the line that -# reports the size of the following chunk. -# Empty line is not distinguished from eof. The caller must -# be able to handle this. -# -# Arguments -# sock The socket receiving input. -# -# Results: -# The line of text, without trailing newline - -proc http::GetTextLine {sock} { - set tr [fconfigure $sock -translation] - lassign $tr trRead trWrite - fconfigure $sock -translation [list crlf $trWrite] - set r [BlockingGets $sock] - fconfigure $sock -translation $tr - return $r -} - -# http::BlockingRead -# -# Replacement for a blocking read. -# The caller must be a coroutine. -# Used when we expect to read a chunked-encoding -# chunk of known size. - -proc http::BlockingRead {sock size} { - if {$size < 1} { - return - } - set result {} - while 1 { - set need [expr {$size - [string length $result]}] - set block [read $sock $need] - set eof [expr {[catch {eof $sock} tmp] || $tmp}] - append result $block - if {[string length $result] >= $size || $eof} { - return $result - } else { - yield - } - } -} - -# http::BlockingGets -# -# Replacement for a blocking gets. -# The caller must be a coroutine. -# Empty line is not distinguished from eof. The caller must -# be able to handle this. - -proc http::BlockingGets {sock} { - while 1 { - set count [gets $sock line] - set eof [expr {[catch {eof $sock} tmp] || $tmp}] - if {$count >= 0 || $eof} { - return $line - } else { - yield - } - } -} - -# http::CopyStart -# -# Error handling wrapper around fcopy -# -# Arguments -# sock The socket to copy from -# token The token returned from http::geturl -# -# Side Effects -# This closes the connection upon error - -proc http::CopyStart {sock token {initial 1}} { - upvar 0 $token state - if {[info exists state(transfer)] && $state(transfer) eq "chunked"} { - foreach coding [ContentEncoding $token] { - if {$coding eq {deflateX}} { - # Use the standards-compliant choice. - set coding2 decompress - } else { - set coding2 $coding - } - lappend state(zlib) [zlib stream $coding2] - } - MakeTransformationChunked $sock [namespace code [list CopyChunk $token]] - } else { - if {$initial} { - foreach coding [ContentEncoding $token] { - if {$coding eq {deflateX}} { - # Use the standards-compliant choice. - set coding2 decompress - } else { - set coding2 $coding - } - zlib push $coding2 $sock - } - } - if {[catch { - # FIXME Keep-Alive on https tls::socket with unchunked transfer - # hangs until the server times out. A workaround is possible, as for - # the case without -channel, but it does not use the neat "fcopy" - # solution. - fcopy $sock $state(-channel) -size $state(-blocksize) -command \ - [list http::CopyDone $token] - } err]} { - Finish $token $err - } - } - return -} - -proc http::CopyChunk {token chunk} { - upvar 0 $token state - if {[set count [string length $chunk]]} { - incr state(currentsize) $count - if {[info exists state(zlib)]} { - foreach stream $state(zlib) { - set chunk [$stream add $chunk] - } - } - puts -nonewline $state(-channel) $chunk - if {[info exists state(-progress)]} { - namespace eval :: [linsert $state(-progress) end \ - $token $state(totalsize) $state(currentsize)] - } - } else { - Log "CopyChunk Finish - token $token" - if {[info exists state(zlib)]} { - set excess "" - foreach stream $state(zlib) { - catch { - $stream put -finalize $excess - set excess "" - set overflood "" - while {[set overflood [$stream get]] ne ""} { append excess $overflood } - } - } - puts -nonewline $state(-channel) $excess - foreach stream $state(zlib) { $stream close } - unset state(zlib) - } - Eot $token ;# FIX ME: pipelining. - } - return -} - -# http::CopyDone -# -# fcopy completion callback -# -# Arguments -# token The token returned from http::geturl -# count The amount transferred -# -# Side Effects -# Invokes callbacks - -proc http::CopyDone {token count {error {}}} { - variable $token - upvar 0 $token state - set sock $state(sock) - incr state(currentsize) $count - if {[info exists state(-progress)]} { - namespace eval :: $state(-progress) \ - [list $token $state(totalsize) $state(currentsize)] - } - # At this point the token may have been reset. - if {[string length $error]} { - Finish $token $error - } elseif {[catch {eof $sock} iseof] || $iseof} { - Eot $token - } else { - CopyStart $sock $token 0 - } - return -} - -# http::Eot -# -# Called when either: -# a. An eof condition is detected on the socket. -# b. The client decides that the response is complete. -# c. The client detects an inconsistency and aborts the transaction. -# -# Does: -# 1. Set state(status) -# 2. Reverse any Content-Encoding -# 3. Convert charset encoding and line ends if necessary -# 4. Call http::Finish -# -# Arguments -# token The token returned from http::geturl -# force (previously) optional, has no effect -# reason - "eof" means premature EOF (not EOF as the natural end of -# the response) -# - "" means completion of response, with or without EOF -# - anything else describes an error condition other than -# premature EOF. -# -# Side Effects -# Clean up the socket - -proc http::Eot {token {reason {}}} { - variable $token - upvar 0 $token state - if {$reason eq "eof"} { - # Premature eof. - set state(status) eof - set reason {} - } elseif {$reason ne ""} { - # Abort the transaction. - set state(status) $reason - } else { - # The response is complete. - set state(status) ok - } - - if {[string length $state(body)] > 0} { - if {[catch { - foreach coding [ContentEncoding $token] { - if {$coding eq {deflateX}} { - # First try the standards-compliant choice. - set coding2 decompress - if {[catch {zlib $coding2 $state(body)} result]} { - # If that fails, try the MS non-compliant choice. - set coding2 inflate - set state(body) [zlib $coding2 $state(body)] - } else { - # error {failed at standards-compliant deflate} - set state(body) $result - } - } else { - set state(body) [zlib $coding $state(body)] - } - } - } err]} { - Log "error doing decompression for token $token: $err" - Finish $token $err - return - } - - if {!$state(binary)} { - # If we are getting text, set the incoming channel's encoding - # correctly. iso8859-1 is the RFC default, but this could be any - # IANA charset. However, we only know how to convert what we have - # encodings for. - - set enc [CharsetToEncoding $state(charset)] - if {$enc ne "binary"} { - if {[package vsatisfies [package provide Tcl] 9.0-]} { - set state(body) [encoding convertfrom -profile tcl8 $enc $state(body)] - } else { - set state(body) [encoding convertfrom $enc $state(body)] - } - } - - # Translate text line endings. - set state(body) [string map {\r\n \n \r \n} $state(body)] - } - if {[info exists state(-guesstype)] && $state(-guesstype)} { - GuessType $token - } - } - Finish $token $reason - return -} - - -# ------------------------------------------------------------------------------ -# Proc http::GuessType -# ------------------------------------------------------------------------------ -# Command to attempt limited analysis of a resource with undetermined -# Content-Type, i.e. "application/octet-stream". This value can be set for two -# reasons: -# (a) by the server, in a Content-Type header -# (b) by http::geturl, as the default value if the server does not supply a -# Content-Type header. -# -# This command converts a resource if: -# (1) it has type application/octet-stream -# (2) it begins with an XML declaration "?" -# (3) one tag is named "encoding" and has a recognised value; or no "encoding" -# tag exists (defaulting to utf-8) -# -# RFC 9110 Sec. 8.3 states: -# "If a Content-Type header field is not present, the recipient MAY either -# assume a media type of "application/octet-stream" ([RFC2046], Section 4.5.1) -# or examine the data to determine its type." -# -# The RFC goes on to describe the pitfalls of "MIME sniffing", including -# possible security risks. -# -# Arguments: -# token - connection token -# -# Return Value: (boolean) true iff a change has been made -# ------------------------------------------------------------------------------ - -proc http::GuessType {token} { - variable $token - upvar 0 $token state - - if {$state(type) ne {application/octet-stream}} { - return 0 - } - - set body $state(body) - # e.g. { ...} - - if {![regexp -nocase -- {^<[?]xml[[:space:]][^>?]*[?]>} $body match]} { - return 0 - } - # e.g. {} - - set contents [regsub -- {[[:space:]]+} $match { }] - set contents [string range [string tolower $contents] 6 end-2] - # e.g. {version="1.0" encoding="utf-8"} - # without excess whitespace or upper-case letters - - if {![regexp -- {^([^=" ]+="[^"]+" )+$} "$contents "]} { - return 0 - } - # The application/xml default encoding: - set res utf-8 - - set tagList [regexp -all -inline -- {[^=" ]+="[^"]+"} $contents] - foreach tag $tagList { - regexp -- {([^=" ]+)="([^"]+)"} $tag -> name value - if {$name eq {encoding}} { - set res $value - } - } - set enc [CharsetToEncoding $res] - if {$enc eq "binary"} { - return 0 - } - if {[package vsatisfies [package provide Tcl] 9.0-]} { - set state(body) [encoding convertfrom -profile tcl8 $enc $state(body)] - } else { - set state(body) [encoding convertfrom $enc $state(body)] - } - set state(body) [string map {\r\n \n \r \n} $state(body)] - set state(type) application/xml - set state(binary) 0 - set state(charset) $res - return 1 -} - - -# http::wait -- -# -# See documentation for details. -# -# Arguments: -# token Connection token. -# -# Results: -# The status after the wait. - -proc http::wait {token} { - variable $token - upvar 0 $token state - - if {![info exists state(status)] || $state(status) eq ""} { - # We must wait on the original variable name, not the upvar alias - vwait ${token}(status) - } - - return [status $token] -} - -# http::formatQuery -- -# -# See documentation for details. Call http::formatQuery with an even -# number of arguments, where the first is a name, the second is a value, -# the third is another name, and so on. -# -# Arguments: -# args A list of name-value pairs. -# -# Results: -# TODO - -proc http::formatQuery {args} { - if {[llength $args] % 2} { - return \ - -code error \ - -errorcode [list HTTP BADARGCNT $args] \ - {Incorrect number of arguments, must be an even number.} - } - set result "" - set sep "" - foreach i $args { - append result $sep [quoteString $i] - if {$sep eq "="} { - set sep & - } else { - set sep = - } - } - return $result -} - -# http::quoteString -- -# -# Do x-www-urlencoded character mapping -# -# Arguments: -# string The string the needs to be encoded -# -# Results: -# The encoded string - -proc http::quoteString {string} { - variable http - variable formMap - - # The spec says: "non-alphanumeric characters are replaced by '%HH'". Use - # a pre-computed map and [string map] to do the conversion (much faster - # than [regsub]/[subst]). [Bug 1020491] - - if {[package vsatisfies [package provide Tcl] 9.0-]} { - set string [encoding convertto -profile tcl8 $http(-urlencoding) $string] - } else { - set string [encoding convertto $http(-urlencoding) $string] - } - return [string map $formMap $string] -} - -# http::ProxyRequired -- -# Default proxy filter. -# -# Arguments: -# host The destination host -# -# Results: -# The current proxy settings - -proc http::ProxyRequired {host} { - variable http - if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} { - return - } - if {![info exists http(-proxyport)] || ($http(-proxyport) eq {})} { - set port 8080 - } else { - set port $http(-proxyport) - } - - # Simple test (cf. autoproxy) for hosts that must be accessed directly, - # not through the proxy server. - foreach domain $http(-proxynot) { - if {[string match -nocase $domain $host]} { - return {} - } - } - return [list $http(-proxyhost) $port] -} - -# http::CharsetToEncoding -- -# -# Tries to map a given IANA charset to a tcl encoding. If no encoding -# can be found, returns binary. -# - -proc http::CharsetToEncoding {charset} { - variable encodings - - set charset [string tolower $charset] - if {[regexp {iso-?8859-([0-9]+)} $charset -> num]} { - set encoding "iso8859-$num" - } elseif {[regexp {iso-?2022-(jp|kr)} $charset -> ext]} { - set encoding "iso2022-$ext" - } elseif {[regexp {shift[-_]?jis} $charset]} { - set encoding "shiftjis" - } elseif {[regexp {(?:windows|cp)-?([0-9]+)} $charset -> num]} { - set encoding "cp$num" - } elseif {$charset eq "us-ascii"} { - set encoding "ascii" - } elseif {[regexp {(?:iso-?)?lat(?:in)?-?([0-9]+)} $charset -> num]} { - switch -- $num { - 5 {set encoding "iso8859-9"} - 1 - 2 - 3 { - set encoding "iso8859-$num" - } - default { - set encoding "binary" - } - } - } else { - # other charset, like euc-xx, utf-8,... may directly map to encoding - set encoding $charset - } - set idx [lsearch -exact $encodings $encoding] - if {$idx >= 0} { - return $encoding - } else { - return "binary" - } -} - - -# ------------------------------------------------------------------------------ -# Proc http::ContentEncoding -# ------------------------------------------------------------------------------ -# Return the list of content-encoding transformations we need to do in order. -# - # -------------------------------------------------------------------------- - # Options for Accept-Encoding, Content-Encoding: the switch command - # -------------------------------------------------------------------------- - # The symbol deflateX allows http to attempt both versions of "deflate", - # unless there is a -channel - for a -channel, only "decompress" is tried. - # Alternative/extra lines for switch: - # The standards-compliant version of "deflate" can be chosen with: - # deflate { lappend r decompress } - # The Microsoft non-compliant version of "deflate" can be chosen with: - # deflate { lappend r inflate } - # The previously used implementation of "compress", which appears to be - # incorrect and is rarely used by web servers, can be chosen with: - # compress - x-compress { lappend r decompress } - # -------------------------------------------------------------------------- -# -# Arguments: -# token - Connection token. -# -# Return Value: list -# ------------------------------------------------------------------------------ - -proc http::ContentEncoding {token} { - upvar 0 $token state - set r {} - if {[info exists state(coding)]} { - foreach coding [split $state(coding) ,] { - switch -exact -- $coding { - deflate { lappend r deflateX } - gzip - x-gzip { lappend r gunzip } - identity {} - br { - return -code error\ - "content-encoding \"br\" not implemented" - } - default { - Log "unknown content-encoding \"$coding\" ignored" - } - } - } - } - return $r -} - -proc http::ReceiveChunked {chan command} { - set data "" - set size -1 - yield - while {1} { - chan configure $chan -translation {crlf binary} - while {[gets $chan line] < 1} { yield } - chan configure $chan -translation {binary binary} - if {[scan $line %x size] != 1} { - return -code error "invalid size: \"$line\"" - } - set chunk "" - while {$size && ![chan eof $chan]} { - set part [chan read $chan $size] - incr size -[string length $part] - append chunk $part - } - if {[catch { - uplevel #0 [linsert $command end $chunk] - }]} { - http::Log "Error in callback: $::errorInfo" - } - if {[string length $chunk] == 0} { - # channel might have been closed in the callback - catch {chan event $chan readable {}} - return - } - } -} - -# http::SplitCommaSeparatedFieldValue -- -# Return the individual values of a comma-separated field value. -# -# Arguments: -# fieldValue Comma-separated header field value. -# -# Results: -# List of values. -proc http::SplitCommaSeparatedFieldValue {fieldValue} { - set r {} - foreach el [split $fieldValue ,] { - lappend r [string trim $el] - } - return $r -} - - -# http::GetFieldValue -- -# Return the value of a header field. -# -# Arguments: -# headers Headers key-value list -# fieldName Name of header field whose value to return. -# -# Results: -# The value of the fieldName header field -# -# Field names are matched case-insensitively (RFC 7230 Section 3.2). -# -# If the field is present multiple times, it is assumed that the field is -# defined as a comma-separated list and the values are combined (by separating -# them with commas, see RFC 7230 Section 3.2.2) and returned at once. -proc http::GetFieldValue {headers fieldName} { - set r {} - foreach {field value} $headers { - if {[string equal -nocase $fieldName $field]} { - if {$r eq {}} { - set r $value - } else { - append r ", $value" - } - } - } - return $r -} - -proc http::MakeTransformationChunked {chan command} { - coroutine [namespace current]::dechunk$chan ::http::ReceiveChunked $chan $command - chan event $chan readable [namespace current]::dechunk$chan - return -} - -interp alias {} http::data {} http::responseBody -interp alias {} http::code {} http::responseLine -interp alias {} http::mapReply {} http::quoteString -interp alias {} http::meta {} http::responseHeaders -interp alias {} http::metaValue {} http::responseHeaderValue -interp alias {} http::ncode {} http::responseCode - - -# ------------------------------------------------------------------------------ -# Proc http::socketForTls -# ------------------------------------------------------------------------------ -# Command to use in place of ::socket as the value of ::tls::socketCmd. -# This command does the same as http::socket, and also handles https connections -# through a proxy server. -# -# Notes. -# - The proxy server works differently for https and http. This implementation -# is for https. The proxy for http is implemented in http::CreateToken (in -# code that was previously part of http::geturl). -# - This code implicitly uses the tls options set for https in a call to -# http::register, and does not need to call commands tls::*. This simple -# implementation is possible because tls uses a callback to ::socket that can -# be redirected by changing the value of ::tls::socketCmd. -# -# Arguments: -# args - as for ::socket -# -# Return Value: a socket identifier -# ------------------------------------------------------------------------------ - -proc http::socketForTls {args} { - variable http - set host [lindex $args end-1] - set port [lindex $args end] - if { ($http(-proxyfilter) ne {}) - && (![catch {$http(-proxyfilter) $host} proxy]) - } { - set phost [lindex $proxy 0] - set pport [lindex $proxy 1] - } else { - set phost {} - set pport {} - } - if {$phost eq ""} { - set sock [::http::socket {*}$args] - } else { - set sock [::http::SecureProxyConnect {*}$args $phost $pport] - } - return $sock -} - - -# ------------------------------------------------------------------------------ -# Proc http::SecureProxyConnect -# ------------------------------------------------------------------------------ -# Command to open a socket through a proxy server to a remote server for use by -# tls. The caller must perform the tls handshake. -# -# Notes -# - Based on patch supplied by Melissa Chawla in ticket 1173760, and -# Proxy-Authorization header cf. autoproxy by Pat Thoyts. -# - Rewritten as a call to http::geturl, because response headers and body are -# needed if the CONNECT request fails. CONNECT is implemented for this case -# only, by state(bypass). -# - FUTURE WORK: give http::geturl a -connect option for a general CONNECT. -# - The request header Proxy-Connection is discouraged in RFC 7230 (June 2014), -# RFC 9112 (June 2022). -# -# Arguments: -# args - as for ::socket, ending in host, port; with proxy host, proxy -# port appended. -# -# Return Value: a socket identifier -# ------------------------------------------------------------------------------ - -proc http::SecureProxyConnect {args} { - variable http - variable ConnectVar - variable ConnectCounter - variable failedProxyValues - set varName ::http::ConnectVar([incr ConnectCounter]) - - # Extract (non-proxy) target from args. - set host [lindex $args end-3] - set port [lindex $args end-2] - set args [lreplace $args end-3 end-2] - - # Proxy server URL for connection. - # This determines where the socket is opened. - set phost [lindex $args end-1] - set pport [lindex $args end] - if {[string first : $phost] != -1} { - # IPv6 address, wrap it in [] so we can append :pport - set phost "\[${phost}\]" - } - set url http://${phost}:${pport} - # Elements of args other than host and port are not used when - # AsyncTransaction opens a socket. Those elements are -async and the - # -type $tokenName for the https transaction. Option -async is used by - # AsyncTransaction anyway, and -type $tokenName should not be propagated: - # the proxy request adds its own -type value. - - set targ [lsearch -exact $args -type] - if {$targ != -1} { - # Record in the token that this is a proxy call. - set token [lindex $args $targ+1] - upvar 0 ${token} state - set tim $state(-timeout) - set state(proxyUsed) SecureProxyFailed - # This value is overwritten with "SecureProxy" below if the CONNECT is - # successful. If it is unsuccessful, the socket will be closed - # below, and so in this unsuccessful case there are no other transactions - # whose (proxyUsed) must be updated. - } else { - set tim 0 - } - if {$tim == 0} { - # Do not use infinite timeout for the proxy. - set tim 30000 - } - - # Prepare and send a CONNECT request to the proxy, using - # code similar to http::geturl. - set requestHeaders [list Host $host] - lappend requestHeaders Connection keep-alive - if {$http(-proxyauth) != {}} { - lappend requestHeaders Proxy-Authorization $http(-proxyauth) - } - - set token2 [CreateToken $url -keepalive 0 -timeout $tim \ - -headers $requestHeaders -command [list http::AllDone $varName]] - variable $token2 - upvar 0 $token2 state2 - - # Kludges: - # Setting this variable overrides the HTTP request line and also allows - # -headers to override the Connection: header set by -keepalive. - # The arguments "-keepalive 0" ensure that when Finish is called for an - # unsuccessful request, the socket is always closed. - set state2(bypass) "CONNECT $host:$port HTTP/1.1" - - AsyncTransaction $token2 - - if {[info coroutine] ne {}} { - # All callers in the http package are coroutines launched by - # the event loop. - # The cwait command requires a coroutine because it yields - # to the caller; $varName is traced and the coroutine resumes - # when the variable is written. - cwait $varName - } else { - return -code error {code must run in a coroutine} - # For testing with a non-coroutine caller outside the http package. - # vwait $varName - } - unset $varName - - if { ($state2(state) ne "complete") - || ($state2(status) ne "ok") - || (![string is integer -strict $state2(responseCode)]) - } { - set msg {the HTTP request to the proxy server did not return a valid\ - and complete response} - if {[info exists state2(error)]} { - append msg ": " [lindex $state2(error) 0] - } - cleanup $token2 - return -code error $msg - } - - set code $state2(responseCode) - - if {($code >= 200) && ($code < 300)} { - # All OK. The caller in package tls will now call "tls::import $sock". - # The cleanup command does not close $sock. - # Other tidying was done in http::Event. - - # If this is a persistent socket, any other transactions that are - # already marked to use the socket will have their (proxyUsed) updated - # when http::OpenSocket calls http::ConfigureNewSocket. - set state(proxyUsed) SecureProxy - set sock $state2(sock) - cleanup $token2 - return $sock - } - - if {$targ != -1} { - # Non-OK HTTP status code; token is known because option -type - # (cf. targ) was passed through tcltls, and so the useful - # parts of the proxy's response can be copied to state(*). - # Do not copy state2(sock). - # Return the proxy response to the caller of geturl. - foreach name $failedProxyValues { - if {[info exists state2($name)]} { - set state($name) $state2($name) - } - } - set state(connection) close - set msg "proxy connect failed: $code" - # - This error message will be detected by http::OpenSocket and will - # cause it to present the proxy's HTTP response as that of the - # original $token transaction, identified only by state(proxyUsed) - # as the response of the proxy. - # - The cases where this would mislead the caller of http::geturl are - # given a different value of msg (below) so that http::OpenSocket will - # treat them as errors, but will preserve the $token array for - # inspection by the caller. - # - Status code 305 (Proxy Required) was deprecated for security reasons - # in RFC 2616 (June 1999) and in any case should never be served by a - # proxy. - # - Other 3xx responses from the proxy are inappropriate, and should not - # occur. - # - A 401 response from the proxy is inappropriate, and should not - # occur. It would be confusing if returned to the caller. - - if {($code >= 300) && ($code < 400)} { - set msg "the proxy server responded to the HTTP request with an\ - inappropriate $code redirect" - set loc [responseHeaderValue $token2 location] - if {$loc ne {}} { - append msg "to " $loc - } - } elseif {($code == 401)} { - set msg "the proxy server responded to the HTTP request with an\ - inappropriate 401 request for target-host credentials" - } else { - } - } else { - set msg "connection to proxy failed with status code $code" - } - - # - ${token2}(sock) has already been closed because -keepalive 0. - # - Error return does not pass the socket ID to the - # $token transaction, which retains its socket placeholder. - cleanup $token2 - return -code error $msg -} - -proc http::AllDone {varName args} { - set $varName done - return -} - - -# ------------------------------------------------------------------------------ -# Proc http::socket -# ------------------------------------------------------------------------------ -# This command is a drop-in replacement for ::socket. -# Arguments and return value as for ::socket. -# -# Notes. -# - http::socket is specified in place of ::socket by the definition of urlTypes -# in the namespace header of this file (http.tcl). -# - The command makes a simple call to ::socket unless the user has called -# http::config to change the value of -threadlevel from the default value 0. -# - For -threadlevel 1 or 2, if the Thread package is available, the command -# waits in the event loop while the socket is opened in another thread. This -# is a workaround for bug [824251] - it prevents http::geturl from blocking -# the event loop if the DNS lookup or server connection is slow. -# - FIXME Use a thread pool if connections are very frequent. -# - FIXME The peer thread can transfer the socket only to the main interpreter -# in the present thread. Therefore this code works only if this script runs -# in the main interpreter. In a child interpreter, the parent must alias a -# command to ::http::socket in the child, run http::socket in the parent, -# and then transfer the socket to the child. -# - The http::socket command is simple, and can easily be replaced with an -# alternative command that uses a different technique to open a socket while -# entering the event loop. -# - Unexpected behaviour by thread::send -async (Thread 2.8.6). -# An error in thread::send -async causes return of just the error message -# (not the expected 3 elements), and raises a bgerror in the main thread. -# Hence wrap the command with catch as a precaution. -# ------------------------------------------------------------------------------ - -proc http::socket {args} { - variable ThreadVar - variable ThreadCounter - variable http - - LoadThreadIfNeeded - - set targ [lsearch -exact $args -type] - if {$targ != -1} { - set token [lindex $args $targ+1] - set args [lreplace $args $targ $targ+1] - upvar 0 $token state - } - - if {!$http(usingThread)} { - # Use plain "::socket". This is the default. - return [eval ::socket $args] - } - - set defcmd ::socket - set sockargs $args - set script " - set code \[catch { - [list proc ::SockInThread {caller defcmd sockargs} [info body ::http::SockInThread]] - [list ::SockInThread [thread::id] $defcmd $sockargs] - } result opts\] - list \$code \$opts \$result - " - - set state(tid) [thread::create] - set varName ::http::ThreadVar([incr ThreadCounter]) - thread::send -async $state(tid) $script $varName - Log >T Thread Start Wait $args -- coro [info coroutine] $varName - if {[info coroutine] ne {}} { - # All callers in the http package are coroutines launched by - # the event loop. - # The cwait command requires a coroutine because it yields - # to the caller; $varName is traced and the coroutine resumes - # when the variable is written. - cwait $varName - } else { - return -code error {code must run in a coroutine} - # For testing with a non-coroutine caller outside the http package. - # vwait $varName - } - Log >U Thread End Wait $args -- coro [info coroutine] $varName [set $varName] - thread::release $state(tid) - set state(tid) {} - set result [set $varName] - unset $varName - if {(![string is list $result]) || ([llength $result] != 3)} { - return -code error "result from peer thread is not a list of\ - length 3: it is \n$result" - } - lassign $result threadCode threadDict threadResult - if {($threadCode != 0)} { - # This is an error in thread::send. Return the lot. - return -options $threadDict -code error $threadResult - } - - # Now the results of the catch in the peer thread. - lassign $threadResult catchCode errdict sock - - if {($catchCode == 0) && ($sock ni [chan names])} { - return -code error {Transfer of socket from peer thread failed.\ - Check that this script is not running in a child interpreter.} - } - return -options $errdict -code $catchCode $sock -} - -# The commands below are dependencies of http::socket and -# http::SecureProxyConnect and are not used elsewhere. - -# ------------------------------------------------------------------------------ -# Proc http::LoadThreadIfNeeded -# ------------------------------------------------------------------------------ -# Command to load the Thread package if it is needed. If it is needed and not -# loadable, the outcome depends on $http(-threadlevel): -# value 0 => Thread package not required, no problem -# value 1 => operate as if -threadlevel 0 -# value 2 => error return -# -# Arguments: none -# Return Value: none -# ------------------------------------------------------------------------------ - -proc http::LoadThreadIfNeeded {} { - variable http - if {$http(usingThread) || ($http(-threadlevel) == 0)} { - return - } - if {[catch {package require Thread}]} { - if {$http(-threadlevel) == 2} { - set msg {[http::config -threadlevel] has value 2,\ - but the Thread package is not available} - return -code error $msg - } - return - } - set http(usingThread) 1 - return -} - - -# ------------------------------------------------------------------------------ -# Proc http::SockInThread -# ------------------------------------------------------------------------------ -# Command http::socket is a ::socket replacement. It defines and runs this -# command, http::SockInThread, in a peer thread. -# -# Arguments: -# caller -# defcmd -# sockargs -# -# Return value: list of values that describe the outcome. The return is -# intended to be a normal (non-error) return in all cases. -# ------------------------------------------------------------------------------ - -proc http::SockInThread {caller defcmd sockargs} { - package require Thread - - set catchCode [catch {eval $defcmd $sockargs} sock errdict] - if {$catchCode == 0} { - set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict] - } - return [list $catchCode $errdict $sock] -} - - -# ------------------------------------------------------------------------------ -# Proc http::cwaiter::cwait -# ------------------------------------------------------------------------------ -# Command to substitute for vwait, without the ordering issues. -# A command that uses cwait must be a coroutine that is launched by an event, -# e.g. fileevent or after idle, and has no calling code to be resumed upon -# "yield". It cannot return a value. -# -# Arguments: -# varName - fully-qualified name of the variable that the calling script -# will write to resume the coroutine. Any scalar variable or -# array element is permitted. -# coroName - (optional) name of the coroutine to be called when varName is -# written - defaults to this coroutine -# timeout - (optional) timeout value in ms -# timeoutValue - (optional) value to assign to varName if there is a timeout -# -# Return Value: none -# ------------------------------------------------------------------------------ - -namespace eval http::cwaiter { - namespace export cwait - variable log {} - variable logOn 0 -} - -proc http::cwaiter::cwait { - varName {coroName {}} {timeout {}} {timeoutValue {}} -} { - set thisCoro [info coroutine] - if {$thisCoro eq {}} { - return -code error {cwait cannot be called outside a coroutine} - } - if {$coroName eq {}} { - set coroName $thisCoro - } - if {[string range $varName 0 1] ne {::}} { - return -code error {argument varName must be fully qualified} - } - if {$timeout eq {}} { - set toe {} - } elseif {[string is integer -strict $timeout] && ($timeout > 0)} { - set toe [after $timeout [list set $varName $timeoutValue]] - } else { - return -code error {if timeout is supplied it must be a positive integer} - } - - set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe] - trace add variable $varName write $cmd - CoLog "Yield $varName $coroName" - yield - CoLog "Resume $varName $coroName" - return -} - - -# ------------------------------------------------------------------------------ -# Proc http::cwaiter::CwaitHelper -# ------------------------------------------------------------------------------ -# Helper command called by the trace set by cwait. -# - Ignores the arguments added by trace. -# - A simple call to $coroName works, and in error cases gives a suitable stack -# trace, but because it is inside a trace the headline error message is -# something like {can't set "::Result(6)": error}, not the actual -# error. So let the trace command return. -# - Remove the trace immediately. We don't want multiple calls. -# ------------------------------------------------------------------------------ - -proc http::cwaiter::CwaitHelper {varName coroName toe args} { - CoLog "got $varName for $coroName" - set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe] - trace remove variable $varName write $cmd - after cancel $toe - - after 0 $coroName - return -} - - -# ------------------------------------------------------------------------------ -# Proc http::cwaiter::LogInit -# ------------------------------------------------------------------------------ -# Call this command to initiate debug logging and clear the log. -# ------------------------------------------------------------------------------ - -proc http::cwaiter::LogInit {} { - variable log - variable logOn - set log {} - set logOn 1 - return -} - -proc http::cwaiter::LogRead {} { - variable log - return $log -} - -proc http::cwaiter::CoLog {msg} { - variable log - variable logOn - if {$logOn} { - append log $msg \n - } - return -} - -namespace eval http { - namespace import ::http::cwaiter::* -} - -# Local variables: -# indent-tabs-mode: t -# End: diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/logger-0.9.5.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/logger-0.9.5.tm deleted file mode 100644 index 739e1c91..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/logger-0.9.5.tm +++ /dev/null @@ -1,1297 +0,0 @@ -# logger.tcl -- -# -# Tcl implementation of a general logging facility. -# -# Copyright (c) 2003 by David N. Welton -# Copyright (c) 2004-2011 by Michael Schlenker -# Copyright (c) 2006,2015 by Andreas Kupries -# -# See the file license.terms. - -# The logger package provides an 'object oriented' log facility that -# lets you have trees of services, that inherit from one another. -# This is accomplished through the use of Tcl namespaces. - - -package require Tcl 8.5 9 -package provide logger 0.9.5 - -namespace eval ::logger { - namespace eval tree {} - namespace export init enable disable services servicecmd import - - # The active services. - variable services {} - - # The log 'levels'. - variable levels [list debug info notice warn error critical alert emergency] - - # The default global log level used for new logging services - variable enabled "debug" - - # Tcl return codes (in numeric order) - variable RETURN_CODES [list "ok" "error" "return" "break" "continue"] -} - -# Try to load msgcat and fall back to format if it fails -if {[catch {package require msgcat}]} { - interp alias {} ::logger::mc {} ::format -} else { - namespace eval ::logger { - namespace import ::msgcat::mc - } -} - -# ::logger::_nsExists -- -# -# Workaround for missing namespace exists in Tcl 8.2 and 8.3. -# - -if {[package vcompare [package provide Tcl] 8.4] < 0} { - proc ::logger::_nsExists {ns} { - expr {![catch {namespace parent $ns}]} - } -} else { - proc ::logger::_nsExists {ns} { - namespace exists $ns - } -} - -# ::logger::_cmdPrefixExists -- -# -# Utility function to check if a given callback prefix exists, -# this should catch all oddities in prefix names, including spaces, -# glob patterns, non normalized namespaces etc. -# -# Arguments: -# prefix - The command prefix to check -# -# Results: -# 1 or 0 for yes or no -# -proc ::logger::_cmdPrefixExists {prefix} { - set cmd [lindex $prefix 0] - set full [namespace eval :: namespace which [list $cmd]] - if {[string equal $full ""]} {return 0} else {return 1} - # normalize namespaces - set ns [namespace qualifiers $cmd] - set cmd ${ns}::[namespace tail $cmd] - set matches [::info commands ${ns}::*] - if {[lsearch -exact $matches $cmd] != -1} {return 1} - return 0 -} - -# ::logger::walk -- -# -# Walk namespaces, starting in 'start', and evaluate 'code' in -# them. -# -# Arguments: -# start - namespace to start in. -# code - code to execute in namespaces walked. -# -# Side Effects: -# Side effects of code executed. -# -# Results: -# None. - -proc ::logger::walk { start code } { - set children [namespace children $start] - foreach c $children { - logger::walk $c $code - namespace eval $c $code - } -} - -proc ::logger::init {service} { - variable levels - variable services - variable enabled - - if {[string length [string trim $service {:}]] == 0} { - return -code error \ - -errorcode [list LOGGER EMPTY_SERVICENAME] \ - [::logger::mc "Service name invalid. May not consist only of : or be empty"] - } - # We create a 'tree' namespace to house all the services, so - # they are in a 'safe' namespace sandbox, and won't overwrite - # any commands. - namespace eval tree::${service} { - variable service - variable levels - variable oldname - variable enabled - } - - lappend services $service - - set [namespace current]::tree::${service}::service $service - set [namespace current]::tree::${service}::levels $levels - set [namespace current]::tree::${service}::oldname $service - set [namespace current]::tree::${service}::enabled $enabled - - namespace eval tree::${service} { - # Callback to use when the service in question is shut down. - variable delcallback [namespace current]::no-op - - # Callback when the loglevel is changed - variable levelchangecallback [namespace current]::no-op - - # State variable to decide when to call levelcallback - variable inSetLevel 0 - - # The currently configured levelcommands - variable lvlcmds - array set lvlcmds {} - - # List of procedures registered via the trace command - variable traceList "" - - # Flag indicating whether or not tracing is currently enabled - variable tracingEnabled 0 - - # We use this to disable a service completely. In Tcl 8.4 - # or greater, by using this, disabled log calls are a - # no-op! - - proc no-op args {} - - proc stdoutcmd {level text} { - variable service - puts "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'" - } - - proc stderrcmd {level text} { - variable service - puts stderr "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'" - } - - - # setlevel -- - # - # This command differs from enable and disable in that - # it disables all the levels below that selected, and - # then enables all levels above it, which enable/disable - # do not do. - # - # Arguments: - # lv - the level, as defined in $levels. - # - # Side Effects: - # Runs disable for the level, and then enable, in order - # to ensure that all levels are set correctly. - # - # Results: - # None. - - - proc setlevel {lv} { - variable inSetLevel 1 - set oldlvl [currentloglevel] - - # do not allow enable and disable to do recursion - if {[catch { - disable $lv 0 - set newlvl [enable $lv 0] - } msg] == 1} { - return -code error -errorcode $::errorCode $msg - } - # do the recursion here - logger::walk [namespace current] [list setlevel $lv] - - set inSetLevel 0 - lvlchangewrapper $oldlvl $newlvl - return - } - - # enable -- - # - # Enable a particular 'level', and above, for the - # service, and its 'children'. - # - # Arguments: - # lv - the level, as defined in $levels. - # - # Side Effects: - # Enables logging for the particular level, and all - # above it (those more important). It also walks - # through all services that are 'children' and enables - # them at the same level or above. - # - # Results: - # None. - - proc enable {lv {recursion 1}} { - variable levels - set lvnum [lsearch -exact $levels $lv] - if { $lvnum == -1 } { - return -code error \ - -errorcode [list LOGGER INVALID_LEVEL] \ - [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] - } - - variable enabled - set newlevel $enabled - set elnum [lsearch -exact $levels $enabled] - if {($elnum == -1) || ($elnum > $lvnum)} { - set newlevel $lv - } - - variable service - while { $lvnum < [llength $levels] } { - interp alias {} [namespace current]::[lindex $levels $lvnum] \ - {} [namespace current]::[lindex $levels $lvnum]cmd - incr lvnum - } - - if {$recursion} { - logger::walk [namespace current] [list enable $lv] - } - lvlchangewrapper $enabled $newlevel - set enabled $newlevel - } - - # disable -- - # - # Disable a particular 'level', and below, for the - # service, and its 'children'. - # - # Arguments: - # lv - the level, as defined in $levels. - # - # Side Effects: - # Disables logging for the particular level, and all - # below it (those less important). It also walks - # through all services that are 'children' and disables - # them at the same level or below. - # - # Results: - # None. - - proc disable {lv {recursion 1}} { - variable levels - set lvnum [lsearch -exact $levels $lv] - if { $lvnum == -1 } { - return -code error \ - -errorcode [list LOGGER INVALID_LEVEL] \ - [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] - } - - variable enabled - set newlevel $enabled - set elnum [lsearch -exact $levels $enabled] - if {($elnum > -1) && ($elnum <= $lvnum)} { - if {$lvnum+1 >= [llength $levels]} { - set newlevel "none" - } else { - set newlevel [lindex $levels [expr {$lvnum+1}]] - } - } - - while { $lvnum >= 0 } { - - interp alias {} [namespace current]::[lindex $levels $lvnum] {} \ - [namespace current]::no-op - incr lvnum -1 - } - if {$recursion} { - logger::walk [namespace current] [list disable $lv] - } - lvlchangewrapper $enabled $newlevel - set enabled $newlevel - } - - # currentloglevel -- - # - # Get the currently enabled log level for this service. - # - # Arguments: - # none - # - # Side Effects: - # none - # - # Results: - # current log level - # - - proc currentloglevel {} { - variable enabled - return $enabled - } - - # lvlchangeproc -- - # - # Set or introspect a callback for when the logger instance - # changes its loglevel. - # - # Arguments: - # cmd - the Tcl command to call, it is called with two parameters, old and new log level. - # or none for introspection - # - # Side Effects: - # None. - # - # Results: - # If no arguments are given return the current callback cmd. - - proc lvlchangeproc {args} { - variable levelchangecallback - - switch -exact -- [llength [::info level 0]] { - 1 {return $levelchangecallback} - 2 { - if {[::logger::_cmdPrefixExists [lindex $args 0]]} { - set levelchangecallback [lindex $args 0] - } else { - return -code error \ - -errorcode [list LOGGER INVALID_CMD] \ - [::logger::mc "Invalid cmd '%s' - does not exist" [lindex $args 0]] - } - } - default { - return -code error \ - -errorcode [list LOGGER WRONG_NUM_ARGS] \ - [::logger::mc "Wrong # of arguments. Usage: \${log}::lvlchangeproc ?cmd?"] - } - } - } - - proc lvlchangewrapper {old new} { - variable inSetLevel - - # we are called after disable and enable are finished - if {$inSetLevel} {return} - - # no action if level does not change - if {[string equal $old $new]} {return} - - variable levelchangecallback - # no action if levelchangecallback isn't a valid command - if {[::logger::_cmdPrefixExists $levelchangecallback]} { - catch { - uplevel \#0 [linsert $levelchangecallback end $old $new] - } - } - } - - # logproc -- - # - # Command used to create a procedure that is executed to - # perform the logging. This could write to disk, out to - # the network, or something else. - # If two arguments are given, use an existing command. - # If three arguments are given, create a proc. - # - # Arguments: - # lv - the level to log, which must be one of $levels. - # args - either zero, one or two arguments. - # if zero this returns the current command registered - # if one, this is a cmd name that is called for this level - # if two, these are an argument and proc body - # - # Side Effects: - # Creates a logging command to take care of the details - # of logging an event. - # - # Results: - # If called with zero length args, returns the name of the currently - # configured logging procedure. - # - # - - proc logproc {lv args} { - variable levels - variable lvlcmds - - set lvnum [lsearch -exact $levels $lv] - if { ($lvnum == -1) && ($lv != "trace") } { - return -code error \ - -errorcode [list LOGGER INVALID_LEVEL] \ - [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] - } - switch -exact -- [llength $args] { - 0 { - return $lvlcmds($lv) - } - 1 { - set cmd [lindex $args 0] - if {[string equal "[namespace current]::${lv}cmd" $cmd]} {return} - if {[llength [::info commands $cmd]]} { - proc ${lv}cmd args [format { - uplevel 1 [list %s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] - } $cmd] - } else { - return -code error \ - -errorcode [list LOGGER INVALID_CMD] \ - [::logger::mc "Invalid cmd '%s' - does not exist" $cmd] - } - set lvlcmds($lv) $cmd - } - 2 { - foreach {arg body} $args {break} - proc ${lv}cmd args [format {\ - _setservicename args - set val [%s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] - _restoreservice - set val} ${lv}customcmd] - proc ${lv}customcmd $arg $body - set lvlcmds($lv) [namespace current]::${lv}customcmd - } - default { - return -code error \ - -errorcode [list LOGGER WRONG_USAGE] \ - [::logger::mc \ - "Usage: \${log}::logproc level ?cmd?\nor \${log}::logproc level argname body" ] - } - } - } - - - # delproc -- - # - # Set or introspect a callback for when the logger instance - # is deleted. - # - # Arguments: - # cmd - the Tcl command to call. - # or none for introspection - # - # Side Effects: - # None. - # - # Results: - # If no arguments are given return the current callback cmd. - - proc delproc {args} { - variable delcallback - - switch -exact -- [llength [::info level 0]] { - 1 {return $delcallback} - 2 { if {[::logger::_cmdPrefixExists [lindex $args 0]]} { - set delcallback [lindex $args 0] - } else { - return -code error \ - -errorcode [list LOGGER INVALID_CMD] \ - [::logger::mc "Invalid cmd '%s' - does not exist" [lindex $args 0]] - } - } - default { - return -code error \ - -errorcode [list LOGGER WRONG_NUM_ARGS] \ - [::logger::mc "Wrong # of arguments. Usage: \${log}::delproc ?cmd?"] - } - } - } - - - # delete -- - # - # Delete the namespace and its children. - - proc delete {} { - variable delcallback - variable service - - logger::walk [namespace current] delete - if {[::logger::_cmdPrefixExists $delcallback]} { - uplevel \#0 [lrange $delcallback 0 end] - } - # clean up the global services list - set idx [lsearch -exact [logger::services] $service] - if {$idx !=-1} { - set ::logger::services [lreplace [logger::services] $idx $idx] - } - - namespace delete [namespace current] - - } - - # services -- - # - # Return all child services - - proc services {} { - variable service - - set children [list] - foreach srv [logger::services] { - if {[string match "${service}::*" $srv]} { - lappend children $srv - } - } - return $children - } - - # servicename -- - # - # Return the name of the service - - proc servicename {} { - variable service - return $service - } - - proc _setservicename {argname} { - variable service - variable oldname - upvar 1 $argname arg - if {[llength $arg] <= 1} { - return - } - - set count -1 - set newname "" - while {[string equal [lindex $arg [expr {$count+1}]] "-_logger::service"]} { - incr count 2 - set newname [lindex $arg $count] - } - if {[string equal $newname ""]} { - return - } - set oldname $service - set service $newname - # Pop off "-_logger::service " from argument list - set arg [lreplace $arg 0 $count] - } - - proc _restoreservice {} { - variable service - variable oldname - set service $oldname - return - } - - proc trace { action args } { - variable service - - # Allow other boolean values (true, false, yes, no, 0, 1) to be used - # as synonymns for "on" and "off". - - if {[string is boolean $action]} { - set xaction [expr {($action && 1) ? "on" : "off"}] - } else { - set xaction $action - } - - # Check for required arguments for actions/subcommands and dispatch - # to the appropriate procedure. - - switch -- $xaction { - "status" { - return [uplevel 1 [list logger::_trace_status $service $args]] - } - "on" { - if {[llength $args]} { - return -code error \ - -errorcode [list LOGGER WRONG_NUM_ARGS] \ - [::logger::mc "wrong # args: should be \"trace on\""] - } - return [logger::_trace_on $service] - } - "off" { - if {[llength $args]} { - return -code error \ - -errorcode [list LOGGER WRONG_NUM_ARGS] \ - [::logger::mc "wrong # args: should be \"trace off\""] - } - return [logger::_trace_off $service] - } - "add" { - if {![llength $args]} { - return -code error \ - -errorcode [list LOGGER WRONG_NUM_ARGS] \ - [::logger::mc "wrong # args: should be \"trace add ?-ns? ...\""] - } - return [uplevel 1 [list ::logger::_trace_add $service $args]] - } - "remove" { - if {![llength $args]} { - return -code error \ - -errorcode [list LOGGER WRONG_NUM_ARGS] \ - [::logger::mc "wrong # args: should be \"trace remove ?-ns? ...\""] - } - return [uplevel 1 [list ::logger::_trace_remove $service $args]] - } - - default { - return -code error \ - -errorcode [list LOGGER INVALID_ARG] \ - [::logger::mc "Invalid action \"%s\": must be status, add, remove,\ - on, or off" $action] - } - } - } - - # Walk the parent service namespaces to see first, if they - # exist, and if any are enabled, and then, as a - # consequence, enable this one - # too. - - enable $enabled - variable parent [namespace parent] - while {[string compare $parent "::logger::tree"]} { - # If the 'enabled' variable doesn't exist, create the - # whole thing. - if { ! [::info exists ${parent}::enabled] } { - logger::init [string range $parent 16 end] - } - set enabled [set ${parent}::enabled] - enable $enabled - set parent [namespace parent $parent] - } - } - - # Now create the commands for different levels. - - namespace eval tree::${service} { - set parent [namespace parent] - - # We 'inherit' the commands from the parents. This - # means that, if you want to share the same methods with - # children, they should be instantiated after the parent's - # methods have been defined. - - variable lvl ; # prevent creative writing to the global scope - if {[string compare $parent "::logger::tree"]} { - foreach lvl [::logger::levels] { - # OPTIMIZE: do not allow multiple aliases in the hierarchy - # they can always be replaced by more efficient - # direct aliases to the target procs. - interp alias {} [namespace current]::${lvl}cmd \ - {} ${parent}::${lvl}cmd -_logger::service $service - } - # inherit the starting loglevel of the parent service - setlevel [${parent}::currentloglevel] - } else { - foreach lvl [concat [::logger::levels] "trace"] { - proc ${lvl}cmd args [format {\ - _setservicename args - set val [stdoutcmd %s [expr {[llength $args]==1 ? [lindex $args end] : $args}]] - _restoreservice - set val } $lvl] - - set lvlcmds($lvl) [namespace current]::${lvl}cmd - } - setlevel $::logger::enabled - } - unset lvl ; # drop the temp iteration variable - } - - return ::logger::tree::${service} -} - -# ::logger::services -- -# -# Returns a list of all active services. -# -# Arguments: -# None. -# -# Side Effects: -# None. -# -# Results: -# List of active services. - -proc ::logger::services {} { - variable services - return $services -} - -# ::logger::enable -- -# -# Global enable for a certain level. NOTE - this implementation -# isn't terribly effective at the moment, because it might hit -# children before their parents, who will then walk down the -# tree attempting to disable the children again. -# -# Arguments: -# lv - level above which to enable logging. -# -# Side Effects: -# Enables logging in a given level, and all higher levels. -# -# Results: -# None. - -proc ::logger::enable {lv} { - variable services - if {[catch { - foreach sv $services { - ::logger::tree::${sv}::enable $lv - } - } msg] == 1} { - return -code error -errorcode $::errorCode $msg - } -} - -proc ::logger::disable {lv} { - variable services - if {[catch { - foreach sv $services { - ::logger::tree::${sv}::disable $lv - } - } msg] == 1} { - return -code error -errorcode $::errorCode $msg - } -} - -proc ::logger::setlevel {lv} { - variable services - variable enabled - variable levels - if {[lsearch -exact $levels $lv] == -1} { - return -code error \ - -errorcode [list LOGGER INVALID_LEVEL] \ - [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels] - } - set enabled $lv - if {[catch { - foreach sv $services { - ::logger::tree::${sv}::setlevel $lv - } - } msg] == 1} { - return -code error -errorcode $::errorCode $msg - } -} - -# ::logger::levels -- -# -# Introspect the available log levels. Provided so a caller does -# not need to know implementation details or code the list -# himself. -# -# Arguments: -# None. -# -# Side Effects: -# None. -# -# Results: -# levels - The list of valid log levels accepted by enable and disable - -proc ::logger::levels {} { - variable levels - return $levels -} - -# ::logger::servicecmd -- -# -# Get the command token for a given service name. -# -# Arguments: -# service - name of the service. -# -# Side Effects: -# none -# -# Results: -# log - namespace token for this service - -proc ::logger::servicecmd {service} { - variable services - if {[lsearch -exact $services $service] == -1} { - return -code error \ - -errorcode [list LOGGER NO_SUCH_SERVICE] \ - [::logger::mc "Service \"%s\" does not exist." $service] - } - return "::logger::tree::${service}" -} - -# ::logger::import -- -# -# Import the logging commands. -# -# Arguments: -# service - name of the service. -# -# Side Effects: -# creates aliases in the target namespace -# -# Results: -# none - -proc ::logger::import {args} { - variable services - - if {[llength $args] == 0 || [llength $args] > 7} { - return -code error \ - -errorcode [list LOGGER WRONG_NUM_ARGS] \ - [::logger::mc \ - "Wrong # of arguments: \"logger::import ?-all?\ - ?-force?\ - ?-prefix prefix? ?-namespace namespace? service\""] - } - - # process options - # - set import_all 0 - set force 0 - set prefix "" - set ns [uplevel 1 namespace current] - while {[llength $args] > 1} { - set opt [lindex $args 0] - set args [lrange $args 1 end] - switch -exact -- $opt { - -all { set import_all 1} - -prefix { set prefix [lindex $args 0] - set args [lrange $args 1 end] - } - -namespace { - set ns [lindex $args 0] - set args [lrange $args 1 end] - } - -force { - set force 1 - } - default { - return -code error \ - -errorcode [list LOGGER UNKNOWN_ARG] \ - [::logger::mc \ - "Unknown argument: \"%s\" :\nUsage:\ - \"logger::import ?-all? ?-force?\ - ?-prefix prefix? ?-namespace namespace? service\"" $opt] - } - } - } - - # - # build the list of commands to import - # - - set cmds [logger::levels] - lappend cmds "trace" - if {$import_all} { - lappend cmds setlevel enable disable logproc delproc services - lappend cmds servicename currentloglevel delete - } - - # - # check the service argument - # - - set service [lindex $args 0] - if {[lsearch -exact $services $service] == -1} { - return -code error \ - -errorcode [list LOGGER NO_SUCH_SERVICE] \ - [::logger::mc "Service \"%s\" does not exist." $service] - } - - # - # setup the namespace for the import - # - - set sourcens [logger::servicecmd $service] - set localns [uplevel 1 namespace current] - - if {[string match ::* $ns]} { - set importns $ns - } else { - set importns ${localns}::$ns - } - - # fake namespace exists for Tcl 8.2 - 8.3 - if {![_nsExists $importns]} { - namespace eval $importns {} - } - - - # - # prepare the import - # - - set imports "" - foreach cmd $cmds { - set cmdname ${importns}::${prefix}$cmd - set collision [llength [info commands $cmdname]] - if {$collision && !$force} { - return -code error \ - -errorcode [list LOGGER IMPORT_NAME_EXISTS] \ - [::logger::mc "can't import command \"%s\": already exists" $cmdname] - } - lappend imports ${importns}::${prefix}$cmd ${sourcens}::${cmd} - } - - # - # and execute the aliasing after checking all is well - # - - foreach {target source} $imports { - proc $target {args} "uplevel 1 \[linsert \$args 0 $source \]" - } -} - -# ::logger::initNamespace -- -# -# Creates a logger for the specified namespace and makes the log -# commands available to said namespace as well. Allows the initial -# setting of a default log level. -# -# Arguments: -# ns - Namespace to initialize, is also the service name, modulo a ::-prefix -# level - Initial log level, optional, defaults to 'warn'. -# -# Side Effects: -# creates aliases in the target namespace -# -# Results: -# none - -proc ::logger::initNamespace {ns {level {}}} { - set service [string trimleft $ns :] - if {$level == ""} { - # No user-specified level. Figure something out. - # - If the parent service exists then the 'logger::init' - # below will automatically inherit its level. Good enough. - # - Without a parent service go and use a default level of 'warn'. - set parent [string trimleft [namespace qualifiers $service] :] - set hasparent [expr {($parent != {}) && [_nsExists ::logger::tree::${parent}]}] - if {!$hasparent} { - set level warn - } - } - - namespace eval $ns [list ::logger::init $service] - namespace eval $ns [list ::logger::import -force -all -namespace log $service] - if {$level != ""} { - namespace eval $ns [list log::setlevel $level] - } - return -} - -# This procedure handles the "logger::trace status" command. Given no -# arguments, returns a list of all procedures that have been registered -# via "logger::trace add". Given one or more procedure names, it will -# return 1 if all were registered, or 0 if any were not. - -proc ::logger::_trace_status { service procList } { - upvar #0 ::logger::tree::${service}::traceList traceList - - # If no procedure names were given, just return the registered list - - if {![llength $procList]} { - return $traceList - } - - # Get caller's namespace for qualifying unqualified procedure names - - set caller_ns [uplevel 1 namespace current] - set caller_ns [string trimright $caller_ns ":"] - - # Search for any specified proc names that are *not* registered - - foreach procName $procList { - # Make sure the procedure namespace is qualified - - if {![string match "::*" $procName]} { - set procName ${caller_ns}::$procName - } - - # Check if the procedure has been registered for tracing - - if {[lsearch -exact $traceList $procName] == -1} { - return 0 - } - } - - return 1 -} - -# This procedure handles the "logger::trace on" command. If tracing -# is turned off, it will enable Tcl trace handlers for all of the procedures -# registered via "logger::trace add". Does nothing if tracing is already -# turned on. - -proc ::logger::_trace_on { service } { - set tcl_version [package provide Tcl] - - if {[package vcompare $tcl_version "8.4"] < 0} { - return -code error \ - -errorcode [list LOGGER TRACE_NOT_AVAILABLE] \ - [::logger::mc "execution tracing is not available in Tcl %s" $tcl_version] - } - - namespace eval ::logger::tree::${service} { - if {!$tracingEnabled} { - set tracingEnabled 1 - ::logger::_enable_traces $service $traceList - } - } - - return 1 -} - -# This procedure handles the "logger::trace off" command. If tracing -# is turned on, it will disable Tcl trace handlers for all of the procedures -# registered via "logger::trace add", leaving them in the list so they -# tracing on all of them can be enabled again with "logger::trace on". -# Does nothing if tracing is already turned off. - -proc ::logger::_trace_off { service } { - namespace eval ::logger::tree::${service} { - if {$tracingEnabled} { - ::logger::_disable_traces $service $traceList - set tracingEnabled 0 - } - } - - return 1 -} - -# This procedure is used by the logger::trace add and remove commands to -# process the arguments in a common fashion. If the -ns switch is given -# first, this procedure will return a list of all existing procedures in -# all of the namespaces given in remaining arguments. Otherwise, each -# argument is taken to be either a pattern for a glob-style search of -# procedure names or, failing that, a namespace, in which case this -# procedure returns a list of all the procedures matching the given -# pattern (or all in the named namespace, if no procedures match). - -proc ::logger::_trace_get_proclist { inputList } { - set procList "" - - if {[string equal [lindex $inputList 0] "-ns"]} { - # Verify that at least one target namespace was supplied - - set inputList [lrange $inputList 1 end] - if {![llength $inputList]} { - return -code error \ - -errorcode [list LOGGER TARGET_MISSING] \ - [::logger::mc "Must specify at least one namespace target"] - } - - # Rebuild the argument list to contain namespace procedures - - foreach namespace $inputList { - # Don't allow tracing of the logger (or child) namespaces - - if {![string match "::logger::*" $namespace]} { - set nsProcList [::info procs ${namespace}::*] - set procList [concat $procList $nsProcList] - } - } - } else { - # Search for procs or namespaces matching each of the specified - # patterns. - - foreach pattern $inputList { - set matches [uplevel 1 ::info proc $pattern] - - if {![llength $matches]} { - if {[uplevel 1 namespace exists $pattern]} { - set matches [::info procs ${pattern}::*] - } - - # Matched procs will be qualified due to above pattern - - set procList [concat $procList $matches] - } elseif {[string match "::*" $pattern]} { - # Patterns were pre-qualified - add them directly - - set procList [concat $procList $matches] - } else { - # Qualify each proc with the namespace it was in - - set ns [uplevel 1 namespace current] - if {$ns == "::"} { - set ns "" - } - foreach proc $matches { - lappend procList ${ns}::$proc - } - } - } - } - - return $procList -} - -# This procedure handles the "logger::trace add" command. If the tracing -# feature is enabled, it will enable the Tcl entry and leave trace handlers -# for each procedure specified that isn't already being traced. Each -# procedure is added to the list of procedures that the logger trace feature -# should log when tracing is enabled. - -proc ::logger::_trace_add { service procList } { - upvar #0 ::logger::tree::${service}::traceList traceList - - # Handle -ns switch and glob search patterns for procedure names - - set procList [uplevel 1 [list logger::_trace_get_proclist $procList]] - - # Enable tracing for each procedure that has not previously been - # specified via logger::trace add. If tracing is off, this will just - # store the name of the procedure for later when tracing is turned on. - - foreach procName $procList { - if {[lsearch -exact $traceList $procName] == -1} { - lappend traceList $procName - ::logger::_enable_traces $service [list $procName] - } - } -} - -# This procedure handles the "logger::trace remove" command. If the tracing -# feature is enabled, it will remove the Tcl entry and leave trace handlers -# for each procedure specified. Each procedure is removed from the list -# of procedures that the logger trace feature should log when tracing is -# enabled. - -proc ::logger::_trace_remove { service procList } { - upvar #0 ::logger::tree::${service}::traceList traceList - - # Handle -ns switch and glob search patterns for procedure names - - set procList [uplevel 1 [list logger::_trace_get_proclist $procList]] - - # Disable tracing for each proc that previously had been specified - # via logger::trace add. If tracing is off, this will just - # remove the name of the procedure from the trace list so that it - # will be excluded when tracing is turned on. - - foreach procName $procList { - set index [lsearch -exact $traceList $procName] - if {$index != -1} { - set traceList [lreplace $traceList $index $index] - ::logger::_disable_traces $service [list $procName] - } - } -} - -# This procedure enables Tcl trace handlers for all procedures specified. -# It is used both to enable Tcl's tracing for a single procedure when -# removed via "logger::trace add", as well as to enable all traces -# via "logger::trace on". - -proc ::logger::_enable_traces { service procList } { - upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled - - if {$tracingEnabled} { - foreach procName $procList { - ::trace add execution $procName enter \ - [list ::logger::_trace_enter $service] - ::trace add execution $procName leave \ - [list ::logger::_trace_leave $service] - } - } -} - -# This procedure disables Tcl trace handlers for all procedures specified. -# It is used both to disable Tcl's tracing for a single procedure when -# removed via "logger::trace remove", as well as to disable all traces -# via "logger::trace off". - -proc ::logger::_disable_traces { service procList } { - upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled - - if {$tracingEnabled} { - foreach procName $procList { - ::trace remove execution $procName enter \ - [list ::logger::_trace_enter $service] - ::trace remove execution $procName leave \ - [list ::logger::_trace_leave $service] - } - } -} - -######################################################################## -# Trace Handlers -######################################################################## - -# This procedure is invoked upon entry into a procedure being traced -# via "logger::trace add" when tracing is enabled via "logger::trace on" -# to log information about how the procedure was called. - -proc ::logger::_trace_enter { service cmd op } { - # Parse the command - set procName [uplevel 1 namespace origin [lindex $cmd 0]] - set args [lrange $cmd 1 end] - - # Display the message prefix - set callerLvl [expr {[::info level] - 1}] - set calledLvl [::info level] - - lappend message "proc" $procName - lappend message "level" $calledLvl - lappend message "script" [uplevel ::info script] - - # Display the caller information - set caller "" - if {$callerLvl >= 1} { - # Display the name of the caller proc w/prepended namespace - catch { - set callerProcName [lindex [::info level $callerLvl] 0] - set caller [uplevel 2 namespace origin $callerProcName] - } - } - - lappend message "caller" $caller - - # Display the argument names and values - set argSpec [uplevel 1 ::info args $procName] - set argList "" - if {[llength $argSpec]} { - foreach argName $argSpec { - lappend argList $argName - - if {$argName == "args"} { - lappend argList $args - break - } else { - lappend argList [lindex $args 0] - set args [lrange $args 1 end] - } - } - } - - lappend message "procargs" $argList - set message [list $op $message] - - ::logger::tree::${service}::tracecmd $message -} - -# This procedure is invoked upon leaving into a procedure being traced -# via "logger::trace add" when tracing is enabled via "logger::trace on" -# to log information about the result of the procedure call. - -proc ::logger::_trace_leave { service cmd status rc op } { - variable RETURN_CODES - - # Parse the command - set procName [uplevel 1 namespace origin [lindex $cmd 0]] - - # Gather the caller information - set callerLvl [expr {[::info level] - 1}] - set calledLvl [::info level] - - lappend message "proc" $procName "level" $calledLvl - lappend message "script" [uplevel ::info script] - - # Get the name of the proc being returned to w/prepended namespace - set caller "" - catch { - set callerProcName [lindex [::info level $callerLvl] 0] - set caller [uplevel 2 namespace origin $callerProcName] - } - - lappend message "caller" $caller - - # Convert the return code from numeric to verbal - - if {$status < [llength $RETURN_CODES]} { - set status [lindex $RETURN_CODES $status] - } - - lappend message "status" $status - lappend message "result" $rc - - # Display the leave message - - set message [list $op $message] - ::logger::tree::${service}::tracecmd $message - - return 1 -} - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/md5-2.0.8.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/md5-2.0.8.tm deleted file mode 100644 index 51f35dce..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/md5-2.0.8.tm +++ /dev/null @@ -1,739 +0,0 @@ -# md5.tcl - Copyright (C) 2003 Pat Thoyts -# -# MD5 defined by RFC 1321, "The MD5 Message-Digest Algorithm" -# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication" -# -# This is an implementation of MD5 based upon the example code given in -# RFC 1321 and upon the tcllib MD4 implementation and taking some ideas -# from the earlier tcllib md5 version by Don Libes. -# -# This implementation permits incremental updating of the hash and -# provides support for external compiled implementations either using -# critcl (md5c) or Trf. -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- - -package require Tcl 8.2-; # tcl minimum version - -namespace eval ::md5 { - variable accel - array set accel {critcl 0 cryptkit 0 trf 0} - - namespace export md5 hmac MD5Init MD5Update MD5Final - - variable uid - if {![info exists uid]} { - set uid 0 - } -} - -# ------------------------------------------------------------------------- - -# MD5Init -- -# -# Create and initialize an MD5 state variable. This will be -# cleaned up when we call MD5Final -# -proc ::md5::MD5Init {} { - variable accel - variable uid - set token [namespace current]::[incr uid] - upvar #0 $token state - - # RFC1321:3.3 - Initialize MD5 state structure - array set state \ - [list \ - A [expr {0x67452301}] \ - B [expr {0xefcdab89}] \ - C [expr {0x98badcfe}] \ - D [expr {0x10325476}] \ - n 0 i "" ] - if {$accel(cryptkit)} { - cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_MD5 - } elseif {$accel(trf)} { - set s {} - switch -exact -- $::tcl_platform(platform) { - windows { set s [open NUL w] } - unix { set s [open /dev/null w] } - } - if {$s != {}} { - fconfigure $s -translation binary -buffering none - ::md5 -attach $s -mode write \ - -read-type variable \ - -read-destination [subst $token](trfread) \ - -write-type variable \ - -write-destination [subst $token](trfwrite) - array set state [list trfread 0 trfwrite 0 trf $s] - } - } - return $token -} - -# MD5Update -- -# -# This is called to add more data into the hash. You may call this -# as many times as you require. Note that passing in "ABC" is equivalent -# to passing these letters in as separate calls -- hence this proc -# permits hashing of chunked data -# -# If we have a C-based implementation available, then we will use -# it here in preference to the pure-Tcl implementation. -# -proc ::md5::MD5Update {token data} { - variable accel - upvar #0 $token state - - if {$accel(critcl)} { - if {[info exists state(md5c)]} { - set state(md5c) [md5c $data $state(md5c)] - } else { - set state(md5c) [md5c $data] - } - return - } elseif {[info exists state(ckctx)]} { - if {[string length $data] > 0} { - cryptkit::cryptEncrypt $state(ckctx) $data - } - return - } elseif {[info exists state(trf)]} { - puts -nonewline $state(trf) $data - return - } - - # Update the state values - incr state(n) [string length $data] - append state(i) $data - - # Calculate the hash for any complete blocks - set len [string length $state(i)] - for {set n 0} {($n + 64) <= $len} {} { - MD5Hash $token [string range $state(i) $n [incr n 64]] - } - - # Adjust the state for the blocks completed. - set state(i) [string range $state(i) $n end] - return -} - -# MD5Final -- -# -# This procedure is used to close the current hash and returns the -# hash data. Once this procedure has been called the hash context -# is freed and cannot be used again. -# -# Note that the output is 128 bits represented as binary data. -# -proc ::md5::MD5Final {token} { - upvar #0 $token state - - # Check for either of the C-compiled versions. - if {[info exists state(md5c)]} { - set r $state(md5c) - unset state - return $r - } elseif {[info exists state(ckctx)]} { - cryptkit::cryptEncrypt $state(ckctx) "" - cryptkit::cryptGetAttributeString $state(ckctx) \ - CRYPT_CTXINFO_HASHVALUE r 16 - cryptkit::cryptDestroyContext $state(ckctx) - # If nothing was hashed, we get no r variable set! - if {[info exists r]} { - unset state - return $r - } - } elseif {[info exists state(trf)]} { - close $state(trf) - set r $state(trfwrite) - unset state - return $r - } - - # RFC1321:3.1 - Padding - # - set len [string length $state(i)] - set pad [expr {56 - ($len % 64)}] - if {$len % 64 > 56} { - incr pad 64 - } - if {$pad == 0} { - incr pad 64 - } - - #puts "P $pad|bits=[expr {8 * $state(n)}]" - - append state(i) [binary format a$pad \x80] - - # RFC1321:3.2 - Append length in bits as little-endian wide int. - append state(i) [binary format ii [expr {8 * $state(n)}] 0] - - #puts DATA=[Hex $state(i)]([string length $state(i)]) - - # Calculate the hash for the remaining block. - set len [string length $state(i)] - for {set n 0} {($n + 64) <= $len} {} { - MD5Hash $token [string range $state(i) $n [incr n 64]] - } - - #puts md5-post__________________________________________ - #parray ::${token} - - # RFC1321:3.5 - Output - set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)] - unset state - - #puts HASH=[Hex $r] - return $r -} - -# ------------------------------------------------------------------------- -# HMAC Hashed Message Authentication (RFC 2104) -# -# hmac = H(K xor opad, H(K xor ipad, text)) -# - -# HMACInit -- -# -# This is equivalent to the MD5Init procedure except that a key is -# added into the algorithm -# -proc ::md5::HMACInit {K} { - - # Key K is adjusted to be 64 bytes long. If K is larger, then use - # the MD5 digest of K and pad this instead. - set len [string length $K] - if {$len > 64} { - set tok [MD5Init] - MD5Update $tok $K - set K [MD5Final $tok] - set len [string length $K] - } - set pad [expr {64 - $len}] - append K [string repeat \0 $pad] - - # Cacluate the padding buffers. - set Ki {} - set Ko {} - binary scan $K i16 Ks - foreach k $Ks { - append Ki [binary format i [expr {$k ^ 0x36363636}]] - append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]] - } - - set tok [MD5Init] - MD5Update $tok $Ki; # initialize with the inner pad - - # preserve the Ko value for the final stage. - # FRINK: nocheck - set [subst $tok](Ko) $Ko - - return $tok -} - -# HMACUpdate -- -# -# Identical to calling MD5Update -# -proc ::md5::HMACUpdate {token data} { - MD5Update $token $data - return -} - -# HMACFinal -- -# -# This is equivalent to the MD5Final procedure. The hash context is -# closed and the binary representation of the hash result is returned. -# -proc ::md5::HMACFinal {token} { - upvar #0 $token state - - set tok [MD5Init]; # init the outer hashing function - MD5Update $tok $state(Ko); # prepare with the outer pad. - MD5Update $tok [MD5Final $token]; # hash the inner result - return [MD5Final $tok] -} - -# ------------------------------------------------------------------------- -# Description: -# This is the core MD5 algorithm. It is a lot like the MD4 algorithm but -# includes an extra round and a set of constant modifiers throughout. -# -# Note: -# This function body is substituted later on to inline some of the -# procedures and to make is a bit more comprehensible. -# -set ::md5::MD5Hash_body { - variable $token - upvar 0 $token state - - #puts TR__=[Hex $msg]([string length $msg]) - - # RFC1321:3.4 - Process Message in 16-Word Blocks - binary scan $msg i* blocks - foreach {X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15} $blocks { - #puts BL - - set A $state(A) - set B $state(B) - set C $state(C) - set D $state(D) - - # Round 1 - # Let [abcd k s i] denote the operation - # a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s). - # Do the following 16 operations. - # [ABCD 0 7 1] [DABC 1 12 2] [CDAB 2 17 3] [BCDA 3 22 4] - set A [expr {$B + (($A + [F $B $C $D] + $X0 + $T01) <<< 7)}] - set D [expr {$A + (($D + [F $A $B $C] + $X1 + $T02) <<< 12)}] - set C [expr {$D + (($C + [F $D $A $B] + $X2 + $T03) <<< 17)}] - set B [expr {$C + (($B + [F $C $D $A] + $X3 + $T04) <<< 22)}] - # [ABCD 4 7 5] [DABC 5 12 6] [CDAB 6 17 7] [BCDA 7 22 8] - set A [expr {$B + (($A + [F $B $C $D] + $X4 + $T05) <<< 7)}] - set D [expr {$A + (($D + [F $A $B $C] + $X5 + $T06) <<< 12)}] - set C [expr {$D + (($C + [F $D $A $B] + $X6 + $T07) <<< 17)}] - set B [expr {$C + (($B + [F $C $D $A] + $X7 + $T08) <<< 22)}] - # [ABCD 8 7 9] [DABC 9 12 10] [CDAB 10 17 11] [BCDA 11 22 12] - set A [expr {$B + (($A + [F $B $C $D] + $X8 + $T09) <<< 7)}] - set D [expr {$A + (($D + [F $A $B $C] + $X9 + $T10) <<< 12)}] - set C [expr {$D + (($C + [F $D $A $B] + $X10 + $T11) <<< 17)}] - set B [expr {$C + (($B + [F $C $D $A] + $X11 + $T12) <<< 22)}] - # [ABCD 12 7 13] [DABC 13 12 14] [CDAB 14 17 15] [BCDA 15 22 16] - set A [expr {$B + (($A + [F $B $C $D] + $X12 + $T13) <<< 7)}] - set D [expr {$A + (($D + [F $A $B $C] + $X13 + $T14) <<< 12)}] - set C [expr {$D + (($C + [F $D $A $B] + $X14 + $T15) <<< 17)}] - set B [expr {$C + (($B + [F $C $D $A] + $X15 + $T16) <<< 22)}] - - # Round 2. - # Let [abcd k s i] denote the operation - # a = b + ((a + G(b,c,d) + X[k] + Ti) <<< s) - # Do the following 16 operations. - # [ABCD 1 5 17] [DABC 6 9 18] [CDAB 11 14 19] [BCDA 0 20 20] - set A [expr {$B + (($A + [G $B $C $D] + $X1 + $T17) <<< 5)}] - set D [expr {$A + (($D + [G $A $B $C] + $X6 + $T18) <<< 9)}] - set C [expr {$D + (($C + [G $D $A $B] + $X11 + $T19) <<< 14)}] - set B [expr {$C + (($B + [G $C $D $A] + $X0 + $T20) <<< 20)}] - # [ABCD 5 5 21] [DABC 10 9 22] [CDAB 15 14 23] [BCDA 4 20 24] - set A [expr {$B + (($A + [G $B $C $D] + $X5 + $T21) <<< 5)}] - set D [expr {$A + (($D + [G $A $B $C] + $X10 + $T22) <<< 9)}] - set C [expr {$D + (($C + [G $D $A $B] + $X15 + $T23) <<< 14)}] - set B [expr {$C + (($B + [G $C $D $A] + $X4 + $T24) <<< 20)}] - # [ABCD 9 5 25] [DABC 14 9 26] [CDAB 3 14 27] [BCDA 8 20 28] - set A [expr {$B + (($A + [G $B $C $D] + $X9 + $T25) <<< 5)}] - set D [expr {$A + (($D + [G $A $B $C] + $X14 + $T26) <<< 9)}] - set C [expr {$D + (($C + [G $D $A $B] + $X3 + $T27) <<< 14)}] - set B [expr {$C + (($B + [G $C $D $A] + $X8 + $T28) <<< 20)}] - # [ABCD 13 5 29] [DABC 2 9 30] [CDAB 7 14 31] [BCDA 12 20 32] - set A [expr {$B + (($A + [G $B $C $D] + $X13 + $T29) <<< 5)}] - set D [expr {$A + (($D + [G $A $B $C] + $X2 + $T30) <<< 9)}] - set C [expr {$D + (($C + [G $D $A $B] + $X7 + $T31) <<< 14)}] - set B [expr {$C + (($B + [G $C $D $A] + $X12 + $T32) <<< 20)}] - - # Round 3. - # Let [abcd k s i] denote the operation - # a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s) - # Do the following 16 operations. - # [ABCD 5 4 33] [DABC 8 11 34] [CDAB 11 16 35] [BCDA 14 23 36] - set A [expr {$B + (($A + [H $B $C $D] + $X5 + $T33) <<< 4)}] - set D [expr {$A + (($D + [H $A $B $C] + $X8 + $T34) <<< 11)}] - set C [expr {$D + (($C + [H $D $A $B] + $X11 + $T35) <<< 16)}] - set B [expr {$C + (($B + [H $C $D $A] + $X14 + $T36) <<< 23)}] - # [ABCD 1 4 37] [DABC 4 11 38] [CDAB 7 16 39] [BCDA 10 23 40] - set A [expr {$B + (($A + [H $B $C $D] + $X1 + $T37) <<< 4)}] - set D [expr {$A + (($D + [H $A $B $C] + $X4 + $T38) <<< 11)}] - set C [expr {$D + (($C + [H $D $A $B] + $X7 + $T39) <<< 16)}] - set B [expr {$C + (($B + [H $C $D $A] + $X10 + $T40) <<< 23)}] - # [ABCD 13 4 41] [DABC 0 11 42] [CDAB 3 16 43] [BCDA 6 23 44] - set A [expr {$B + (($A + [H $B $C $D] + $X13 + $T41) <<< 4)}] - set D [expr {$A + (($D + [H $A $B $C] + $X0 + $T42) <<< 11)}] - set C [expr {$D + (($C + [H $D $A $B] + $X3 + $T43) <<< 16)}] - set B [expr {$C + (($B + [H $C $D $A] + $X6 + $T44) <<< 23)}] - # [ABCD 9 4 45] [DABC 12 11 46] [CDAB 15 16 47] [BCDA 2 23 48] - set A [expr {$B + (($A + [H $B $C $D] + $X9 + $T45) <<< 4)}] - set D [expr {$A + (($D + [H $A $B $C] + $X12 + $T46) <<< 11)}] - set C [expr {$D + (($C + [H $D $A $B] + $X15 + $T47) <<< 16)}] - set B [expr {$C + (($B + [H $C $D $A] + $X2 + $T48) <<< 23)}] - - # Round 4. - # Let [abcd k s i] denote the operation - # a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s) - # Do the following 16 operations. - # [ABCD 0 6 49] [DABC 7 10 50] [CDAB 14 15 51] [BCDA 5 21 52] - set A [expr {$B + (($A + [I $B $C $D] + $X0 + $T49) <<< 6)}] - set D [expr {$A + (($D + [I $A $B $C] + $X7 + $T50) <<< 10)}] - set C [expr {$D + (($C + [I $D $A $B] + $X14 + $T51) <<< 15)}] - set B [expr {$C + (($B + [I $C $D $A] + $X5 + $T52) <<< 21)}] - # [ABCD 12 6 53] [DABC 3 10 54] [CDAB 10 15 55] [BCDA 1 21 56] - set A [expr {$B + (($A + [I $B $C $D] + $X12 + $T53) <<< 6)}] - set D [expr {$A + (($D + [I $A $B $C] + $X3 + $T54) <<< 10)}] - set C [expr {$D + (($C + [I $D $A $B] + $X10 + $T55) <<< 15)}] - set B [expr {$C + (($B + [I $C $D $A] + $X1 + $T56) <<< 21)}] - # [ABCD 8 6 57] [DABC 15 10 58] [CDAB 6 15 59] [BCDA 13 21 60] - set A [expr {$B + (($A + [I $B $C $D] + $X8 + $T57) <<< 6)}] - set D [expr {$A + (($D + [I $A $B $C] + $X15 + $T58) <<< 10)}] - set C [expr {$D + (($C + [I $D $A $B] + $X6 + $T59) <<< 15)}] - set B [expr {$C + (($B + [I $C $D $A] + $X13 + $T60) <<< 21)}] - # [ABCD 4 6 61] [DABC 11 10 62] [CDAB 2 15 63] [BCDA 9 21 64] - set A [expr {$B + (($A + [I $B $C $D] + $X4 + $T61) <<< 6)}] - set D [expr {$A + (($D + [I $A $B $C] + $X11 + $T62) <<< 10)}] - set C [expr {$D + (($C + [I $D $A $B] + $X2 + $T63) <<< 15)}] - set B [expr {$C + (($B + [I $C $D $A] + $X9 + $T64) <<< 21)}] - - # Then perform the following additions. (That is, increment each - # of the four registers by the value it had before this block - # was started.) - incr state(A) $A - incr state(B) $B - incr state(C) $C - incr state(D) $D - } - - return -} - -proc ::md5::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}} -proc ::md5::bytes {v} { - #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v] - format %c%c%c%c \ - [expr {0xFF & $v}] \ - [expr {(0xFF00 & $v) >> 8}] \ - [expr {(0xFF0000 & $v) >> 16}] \ - [expr {((0xFF000000 & $v) >> 24) & 0xFF}] -} - -# 32bit rotate-left -proc ::md5::<<< {v n} { - return [expr {((($v << $n) \ - | (($v >> (32 - $n)) \ - & (0x7FFFFFFF >> (31 - $n))))) \ - & 0xFFFFFFFF}] -} - -# Convert our <<< pseudo-operator into a procedure call. -regsub -all -line \ - {\[expr {(\$[ABCD]) \+ \(\((.*)\)\s+<<<\s+(\d+)\)}\]} \ - $::md5::MD5Hash_body \ - {[expr {int(\1 + [<<< [expr {\2}] \3])}]} \ - ::md5::MD5Hash_body - -# RFC1321:3.4 - function F -proc ::md5::F {X Y Z} { - return [expr {($X & $Y) | ((~$X) & $Z)}] -} - -# Inline the F function -regsub -all -line \ - {\[F (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \ - $::md5::MD5Hash_body \ - {( (\1 \& \2) | ((~\1) \& \3) )} \ - ::md5::MD5Hash_body - -# RFC1321:3.4 - function G -proc ::md5::G {X Y Z} { - return [expr {(($X & $Z) | ($Y & (~$Z)))}] -} - -# Inline the G function -regsub -all -line \ - {\[G (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \ - $::md5::MD5Hash_body \ - {(((\1 \& \3) | (\2 \& (~\3))))} \ - ::md5::MD5Hash_body - -# RFC1321:3.4 - function H -proc ::md5::H {X Y Z} { - return [expr {$X ^ $Y ^ $Z}] -} - -# Inline the H function -regsub -all -line \ - {\[H (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \ - $::md5::MD5Hash_body \ - {(\1 ^ \2 ^ \3)} \ - ::md5::MD5Hash_body - -# RFC1321:3.4 - function I -proc ::md5::I {X Y Z} { - return [expr {$Y ^ ($X | (~$Z))}] -} - -# Inline the I function -regsub -all -line \ - {\[I (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \ - $::md5::MD5Hash_body \ - {(\2 ^ (\1 | (~\3)))} \ - ::md5::MD5Hash_body - - -# RFC 1321:3.4 step 4: inline the set of constant modifiers. -namespace eval md5 { - variable tName - variable tVal - variable map - foreach tName { - T01 T02 T03 T04 T05 T06 T07 T08 T09 T10 - T11 T12 T13 T14 T15 T16 T17 T18 T19 T20 - T21 T22 T23 T24 T25 T26 T27 T28 T29 T30 - T31 T32 T33 T34 T35 T36 T37 T38 T39 T40 - T41 T42 T43 T44 T45 T46 T47 T48 T49 T50 - T51 T52 T53 T54 T55 T56 T57 T58 T59 T60 - T61 T62 T63 T64 - } tVal { - 0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee - 0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501 - 0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be - 0x6b901122 0xfd987193 0xa679438e 0x49b40821 - - 0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa - 0xd62f105d 0x2441453 0xd8a1e681 0xe7d3fbc8 - 0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed - 0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a - - 0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c - 0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70 - 0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05 - 0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665 - - 0xf4292244 0x432aff97 0xab9423a7 0xfc93a039 - 0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1 - 0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1 - 0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391 - } { - lappend map \$$tName $tVal - } - set ::md5::MD5Hash_body [string map $map $::md5::MD5Hash_body] - unset map tName tVal -} - -# Define the MD5 hashing procedure with inline functions. -proc ::md5::MD5Hash {token msg} $::md5::MD5Hash_body -unset ::md5::MD5Hash_body - -# ------------------------------------------------------------------------- - -if {[package provide Trf] != {}} { - interp alias {} ::md5::Hex {} ::hex -mode encode -- -} else { - proc ::md5::Hex {data} { - binary scan $data H* result - return [string toupper $result] - } -} - -# ------------------------------------------------------------------------- - -# LoadAccelerator -- -# -# This package can make use of a number of compiled extensions to -# accelerate the digest computation. This procedure manages the -# use of these extensions within the package. During normal usage -# this should not be called, but the test package manipulates the -# list of enabled accelerators. -# -proc ::md5::LoadAccelerator {name} { - variable accel - set r 0 - switch -exact -- $name { - critcl { - if {![catch {package require tcllibc}] - || ![catch {package require md5c}]} { - set r [expr {[info commands ::md5::md5c] != {}}] - } - } - cryptkit { - if {![catch {package require cryptkit}]} { - set r [expr {![catch {cryptkit::cryptInit}]}] - } - } - trf { - if {![catch {package require Trf}]} { - set r [expr {![catch {::md5 aa} msg]}] - } - } - default { - return -code error "invalid accelerator package:\ - must be one of [join [array names accel] {, }]" - } - } - set accel($name) $r -} - -# ------------------------------------------------------------------------- - -# Description: -# Pop the nth element off a list. Used in options processing. -# -proc ::md5::Pop {varname {nth 0}} { - upvar $varname args - set r [lindex $args $nth] - set args [lreplace $args $nth $nth] - return $r -} - -# ------------------------------------------------------------------------- - -# fileevent handler for chunked file hashing. -# -proc ::md5::Chunk {token channel {chunksize 4096}} { - upvar #0 $token state - - if {[eof $channel]} { - fileevent $channel readable {} - set state(reading) 0 - } - - MD5Update $token [read $channel $chunksize] -} - -# ------------------------------------------------------------------------- - -proc ::md5::md5 {args} { - array set opts {-hex 0 -filename {} -channel {} -chunksize 4096} - while {[string match -* [set option [lindex $args 0]]]} { - switch -glob -- $option { - -hex { set opts(-hex) 1 } - -file* { set opts(-filename) [Pop args 1] } - -channel { set opts(-channel) [Pop args 1] } - -chunksize { set opts(-chunksize) [Pop args 1] } - default { - if {[llength $args] == 1} { break } - if {[string compare $option "--"] == 0} { Pop args; break } - set err [join [lsort [array names opts]] ", "] - return -code error "bad option $option:\ - must be one of $err\nlen: [llength $args]" - } - } - Pop args - } - - if {$opts(-filename) != {}} { - set opts(-channel) [open $opts(-filename) r] - fconfigure $opts(-channel) -translation binary - } - - if {$opts(-channel) == {}} { - - if {[llength $args] != 1} { - return -code error "wrong # args:\ - should be \"md5 ?-hex? -filename file | string\"" - } - set tok [MD5Init] - - #puts md5_______________________________________________ - #parray ::${tok} - - #puts IN=(([lindex $args 0])) - MD5Update $tok [lindex $args 0] - - #puts md5-final_________________________________________ - #parray ::${tok} - - set r [MD5Final $tok] - - } else { - - set tok [MD5Init] - # FRINK: nocheck - set [subst $tok](reading) 1 - fileevent $opts(-channel) readable \ - [list [namespace origin Chunk] \ - $tok $opts(-channel) $opts(-chunksize)] - vwait [subst $tok](reading) - set r [MD5Final $tok] - - # If we opened the channel - we should close it too. - if {$opts(-filename) != {}} { - close $opts(-channel) - } - } - - if {$opts(-hex)} { - set r [Hex $r] - } - return $r -} - -# ------------------------------------------------------------------------- - -proc ::md5::hmac {args} { - array set opts {-hex 0 -filename {} -channel {} -chunksize 4096} - while {[string match -* [set option [lindex $args 0]]]} { - switch -glob -- $option { - -key { set opts(-key) [Pop args 1] } - -hex { set opts(-hex) 1 } - -file* { set opts(-filename) [Pop args 1] } - -channel { set opts(-channel) [Pop args 1] } - -chunksize { set opts(-chunksize) [Pop args 1] } - default { - if {[llength $args] == 1} { break } - if {[string compare $option "--"] == 0} { Pop args; break } - set err [join [lsort [array names opts]] ", "] - return -code error "bad option $option:\ - must be one of $err" - } - } - Pop args - } - - if {![info exists opts(-key)]} { - return -code error "wrong # args:\ - should be \"hmac ?-hex? -key key -filename file | string\"" - } - - if {$opts(-filename) != {}} { - set opts(-channel) [open $opts(-filename) r] - fconfigure $opts(-channel) -translation binary - } - - if {$opts(-channel) == {}} { - - if {[llength $args] != 1} { - return -code error "wrong # args:\ - should be \"hmac ?-hex? -key key -filename file | string\"" - } - set tok [HMACInit $opts(-key)] - HMACUpdate $tok [lindex $args 0] - set r [HMACFinal $tok] - - } else { - - set tok [HMACInit $opts(-key)] - # FRINK: nocheck - set [subst $tok](reading) 1 - fileevent $opts(-channel) readable \ - [list [namespace origin Chunk] \ - $tok $opts(-channel) $opts(-chunksize)] - vwait [subst $tok](reading) - set r [HMACFinal $tok] - - # If we opened the channel - we should close it too. - if {$opts(-filename) != {}} { - close $opts(-channel) - } - } - - if {$opts(-hex)} { - set r [Hex $r] - } - return $r -} - -# ------------------------------------------------------------------------- - -# Try and load a compiled extension to help. -namespace eval ::md5 { - variable e - foreach e {critcl cryptkit trf} { if {[LoadAccelerator $e]} { break } } - unset e -} - -package provide md5 2.0.8 - -# ------------------------------------------------------------------------- -# Local Variables: -# mode: tcl -# indent-tabs-mode: nil -# End: - - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/metaface-1.2.5.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/metaface-1.2.5.tm deleted file mode 100644 index ebcf579e..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/metaface-1.2.5.tm +++ /dev/null @@ -1,6411 +0,0 @@ -package require dictutils -package provide metaface [namespace eval metaface { - variable version - set version 1.2.5 -}] - - - - -#example datastructure: -#$_ID_ -#{ -#i -# { -# this -# { -# {16 ::p::16 item ::>x {}} -# } -# role2 -# { -# {17 ::p::17 item ::>y {}} -# {18 ::p::18 item ::>z {}} -# } -# } -#context {} -#} - -#$MAP -#invocantdata {16 ::p::16 item ::>x {}} -#interfaces {level0 -# { -# api0 {stack {123 999}} -# api1 {stack {333}} -# } -# level0_default api0 -# level1 -# { -# } -# level1_default {} -# } -#patterndata {patterndefaultmethod {}} - - -namespace eval ::p::predator {} -#temporary alternative to ::p::internals namespace. -# - place predator functions here until ready to replace internals. - - -namespace eval ::p::snap { - variable id 0 ;#ever-increasing non-reused snapshot-id to identify ::p::snapshot namespaces used to allow overlay-rollbacks. -} - - - - -# not called directly. Retrieved using 'info body ::p::predator::getprop_template' -#review - why use a proc instead of storing it as a string? -proc ::p::predator::getprop_template {_ID_ args} { - set OID [lindex [dict get $_ID_ i this] 0 0] - if {"%varspace%" eq ""} { - set ns ::p::${OID} - } else { - if {[string match "::*" "%varspace%"]} { - set ns "%varspace%" - } else { - set ns ::p::${OID}::%varspace% - } - } - - - if {[llength $args]} { - #lassign [lindex $invocant 0] OID alias itemCmd cmd - if {[array exists ${ns}::o_%prop%]} { - #return [set ${ns}::o_%prop%($args)] - if {[llength $args] == 1} { - return [set ::p::${OID}::o_%prop%([lindex $args 0])] - } else { - return [lindex [set ::p::${OID}::o_%prop%([lindex $args 0])] {*}[lrange $args 1 end]] - } - } else { - set val [set ${ns}::o_%prop%] - - set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] - if {$rType eq "object"} { - #return [$val . item {*}$args] - return [$val {*}$args] - } else { - #treat as list? - return [lindex $val $args] - } - } - } else { - return [set ${ns}::o_%prop%] - } -} - - -proc ::p::predator::getprop_template_immediate {_ID_ args} { - if {[llength $args]} { - if {[array exists %ns%::o_%prop%]} { - return [set %ns%::o_%prop%($args)] - } else { - set val [set %ns%::o_%prop%] - set rType [expr {[scan [namespace tail $val] >%s rType] ? {object} : {unknown}}] - if {$rType eq "object"} { - #return [$val . item {*}$args] - #don't assume defaultmethod named 'item'! - return [$val {*}$args] - } else { - #treat as list? - return [lindex $val $args] - } - } - } else { - return [set %ns%::o_%prop%] - } -} - - - - - - - - -proc ::p::predator::getprop_array {_ID_ prop args} { - set OID [lindex [dict get $_ID_ i this] 0 0] - - #upvar 0 ::p::${OID}::o_${prop} prop - #1st try: assume array - if {[catch {array get ::p::${OID}::o_${prop}} result]} { - #treat as list (why?) - #!review - if {[info exists ::p::${OID}::o_${prop}]} { - array set temp [::list] - set i 0 - foreach element ::p::${OID}::o_${prop} { - set temp($i) $element - incr i - } - set result [array get temp] - } else { - error "unable to retrieve [set ::p::${OID}::o_${prop}] contents in 'array get' format" - } - } - return $result -} - -proc ::p::predator::setprop_template {prop _ID_ args} { - set OID [lindex [dict get $_ID_ i this] 0 0] - if {"%varspace%" eq ""} { - set ns ::p::${OID} - } else { - if {[string match "::*" "%varspace%"]} { - set ns "%varspace%" - } else { - set ns ::p::${OID}::%varspace% - } - } - - - if {[llength $args] == 1} { - #return [set ::p::${OID}::o_%prop% [lindex $args 0]] - return [set ${ns}::o_%prop% [lindex $args 0]] - - } else { - if {[array exists ${ns}::o_%prop%] || ![info exists ${ns}::o_%prop%]} { - #treat attempt to perform indexed write to nonexistant var, same as indexed write to array - - #2 args - single index followed by a value - if {[llength $args] == 2} { - return [set ${ns}::o_%prop%([lindex $args 0]) [lindex $args 1]] - } else { - #multiple indices - #return [set ::p::${OID}::o_%prop%([lrange $args 0 end-1]) [lindex $args end]] - return [lset ${ns}::o_%prop%([lindex $args 0]) {*}[lrange $args 1 end-1] [lindex $args end] ] - } - } else { - #treat as list - return [lset ${ns}::o_%prop% [lrange $args 0 end-1] [lindex $args end]] - } - } -} - -#-------------------------------------- -#property read & write traces -#-------------------------------------- - - -proc ::p::predator::propref_trace_read {get_cmd _ID_ refname prop indices vtraced idx op} { - - #puts stderr "\t-->propref_trace_read get_cmd:'$get_cmd' refname:'$refname' prop:'$prop' indices:'$indices' $vtraced idx:'$idx' " - - #set cmd ::p::${OID}::(GET)$prop ;#this is an interp alias to the head of the implementation command-chain. - - if {[llength $idx]} { - if {[llength $idx] == 1} { - set ${refname}($idx) [$get_cmd $_ID_ {*}$indices $idx] - } else { - lset ${refname}([lindex $idx 0]) [lrange $idx 1 end] [$get_cmd $_ID_ {*}$indices {*}$idx] - } - return ;#return value ignored - in a trace we can only return the value by setting the traced variable to a value - } else { - if {![info exists $refname]} { - set $refname [$get_cmd $_ID_ {*}$indices] - } else { - set newval [$get_cmd $_ID_ {*}$indices] - if {[set $refname] ne $newval} { - set $refname $newval - } - } - return - } -} - - - - -proc ::p::predator::propref_trace_write {_ID_ OID full_varspace refname vname idx op} { - #note 'vname' may be upvar-ed local - we need the fully qualified name so must use passed in $refname - #puts stdout "\t-->propref_trace_write $OID ref:'$refname' var:'$vname' idx:'$idx'" - - - #derive the name of the write command from the ref var. - set indices [lassign [split [namespace tail $refname] +] prop] - - - #assert - we will never have both a list in indices and an idx value - if {[llength $indices] && ($idx ne "")} { - #since Tcl has no nested arrays - we can't write to an idx within something like ${prop}+x - #review - are there any datastructures which would/should allow this? - #this assertion is really just here as a sanity check for now - error "propref_trace_write unexpected values. Didn't expect a refname of the form ${prop}+* as well as an idx value" - } - - #upvar #0 ::p::${OID}::_meta::map MAP - #puts "-->propref_trace_write map: $MAP" - - #temporarily deactivate refsync trace - #puts stderr -->1>--removing_trace_o_${field} -### trace remove variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] - - #we need to catch, and re-raise any error that we may receive when writing the property - # because we have to reinstate the propvar_write_TraceHandler after the call. - #(e.g there may be a propertywrite handler that deliberately raises an error) - - set excludesync_refs $refname - set cmd ::p::${OID}::(SET)$prop - - - set f_error 0 - if {[catch { - - if {![llength $indices]} { - if {[string length $idx]} { - $cmd $_ID_ $idx [set ${refname}($idx)] - #::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop}($idx) [list] - ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list $idx] - - } else { - $cmd $_ID_ [set $refname] - ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} [list] - } - } else { - #puts " ++>> cmd:$cmd indices:'$indices' refname:'$refname'\n" - $cmd $_ID_ {*}$indices [set $refname] - ### ::p::predator::refsyncvar_write_manualupdate $OID $excludesync_refs $prop ::p::${OID}::o_${prop} $indices - } - - } result]} { - set f_error 1 - } - - - - - #::p::predator::propvar_write_TraceHandler $OID $prop ::p::${OID}::o_${prop} $indices write - #reactivate refsync trace - #puts stderr "****** reactivating refsync trace on o_$field" - #puts stderr -->2>--reactivating_trace_o_${field} - ### trace add variable ::p::${OID}::o_${prop} [::list write] [::list ::p::predator::propvar_write_TraceHandler $OID $prop] - - - if {$f_error} { - #!todo - review error & 'return' functions for proper way to throw error, preserving callstack info for debugging. - # ? return -code error $errMsg ? -errorinfo - - #!quick n dirty - #error $errorMsg - return -code error -errorinfo $::errorInfo $result - } else { - return $result - } -} - - - - - -proc ::p::predator::propref_trace_array {_ID_ OID refname vref idx op} { - #puts stderr "\t-->propref_trace_array OID:$OID refname:'$refname' var:'$vref' index:'$idx' operation:'$op'" - #NOTE - do not rely on $vref !!!! (can be upvared - so could be anything. e.g during 'parray' calls it is set to 'array') - - set indices [lassign [split [namespace tail $refname] +] prop] ;#make sure 'prop' is set - - #set updated_value [::p::predator::getprop_array $prop $_ID_] - #puts stderr "-->array_Trace updated_value:$updated_value" - if {[catch {array set $refname [::p::predator::getprop_array $_ID_ $prop ]} errm]} { - puts stderr "-->propref_trace_array error $errm" - array set $refname {} - } - - #return value ignored for -} - - -#-------------------------------------- -# -proc ::p::predator::object_array_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd - - - #don't rely on variable name passed by trace - may have been 'upvar'ed - set refvar ::p::${OID}::_ref::__OBJECT - - #puts "+=====>object_array_trace $map '$vref' '$idx' '$op' refvar: $refvar" - - set iflist [dict get $MAP interfaces level0] - - set plist [list] - - #!todo - get propertylist from cache on object(?) - foreach IFID [lreverse $iflist] { - dict for {prop pdef} [set ::p::${IFID}::_iface::o_properties] { - #lassign $pdef v - if {[catch {lappend plist $prop [set ::p::${OID}::o_${prop}]}]} { - if {[array exists ::p::${OID}::o_${prop}]} { - lappend plist $prop [array get ::p::${OID}::o_${prop}] - } else { - #ignore - array only represents properties that have been set. - #error "property $v is not set" - #!todo - unset corresponding items in $refvar if needed? - } - } - } - } - array set $refvar $plist -} - - -proc ::p::predator::object_read_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd - #don't rely on variable name passed by trace. - set refvar ::p::${OID}::_ref::__OBJECT - - #puts "\n\n+=====>object_read_trace map:'$MAP' '$vref' '$idx' '$op' refvar: $refvar\n\n" - - #!todo? - build a list of all interface properties (cache it on object??) - set iflist [dict get $MAP interfaces level0] - set IID "" - foreach id [lreverse $iflist] { - if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { - set IID $id - break - } - } - - if {[string length $IID]} { - #property - if {[catch {set ${refvar}($idx) [::p::${id}::_iface::(GET)$idx $_ID_]} errmsg]} { - puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg" - } - } else { - #method - error "property '$idx' not found" - } -} - - -proc ::p::predator::object_unset_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP - - lassign [dict get $MAP invocantdata] OID alias itemCmd - - #!todo - ??? - - if {![llength [info commands ::p::${OID}::$idx]]} { - error "no such method or property: '$idx'" - } else { - #!todo? - build a list of all interface properties (cache it on object??) - set iflist [dict get $MAP interfaces level0] - set found 0 - foreach id [lreverse $iflist] { - if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { - set found 1 - break - } - } - - if {$found} { - unset ::p::${OID}::o_$idx - } else { - puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$OID objectcmd:[lindex [dict get $MAP invocantdata] 3] var:$vref prop:$idx" - } - } -} - - -proc ::p::predator::object_write_trace {OID _ID_ vref idx op} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd - #don't rely on variable name passed by trace. - set refvar ::p::${OID}::_ref::__OBJECT - #puts "+=====>object_write_trace $MAP '$vref' '$idx' '$op' refvar: $refvar" - - - if {![llength [info commands ::p::${OID}::$idx]]} { - #!todo - create new property in interface upon attempt to write to non-existant? - # - or should we require some different kind of object-reference for that? - array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx - error "no such method or property: '$idx'" - } else { - #!todo? - build a list of all interface properties (cache it on object??) - set iflist [dict get $MAP interfaces level0] - set IID "" - foreach id [lreverse $iflist] { - if {$idx in [dict keys [set ::p::${id}::_iface::o_properties]]} { - set IID $id - break - } - } - - #$IID is now topmost interface in default iStack which has this property - - if {[string length $IID]} { - #write to defined property - - ::p::${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)] - } else { - #!todo - allow write of method body back to underlying object? - #attempted write to 'method' ..undo(?) - array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx - error "cannot write to method '$idx'" - #for now - disallow - } - } - -} - - - -proc ::p::predator::propref_trace_unset {_ID_ OID refname vref idx op} { - #note 'vref' may be upvar-ed local - we need the fully qualified name so must use passed in $refname - - set refindices [lassign [split [namespace tail $refname] +] prop] - #derive the name of any potential PropertyUnset command from the refname. i.e (UNSET)$prop - #if there is no PropertyUnset command - we unset the underlying variable directly - - trace remove variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] - - - if {[catch { - - #assert if refname is complex (prop+idx etc), we will not get a reference trace with an $idx value - #i.e - if {[llength $refindices] && [string length $idx]} { - puts stderr "\t !!!!! unexpected call to propref_trace_unset oid:'$OID' refname:'$refname' vref:'$vref' idx:'$idx' op:'$op'" - error "unexpected call to propref_trace_unset" - } - - - upvar #0 ::p::${OID}::_meta::map MAP - - set iflist [dict get $MAP interfaces level0] - #find topmost interface containing this $prop - set IID "" - foreach id [lreverse $iflist] { - if {$prop in [dict keys [set ::p::${id}::_iface::o_properties]]} { - set IID $id - break - } - } - if {![string length $IID]} { - error "propref_trace_unset failed to find property '$prop' on objectid $OID ([lindex [dict get $_ID_ i this] 0 3])" - } - - - - - - - if {[string length $idx]} { - #eval "$_alias ${unset_}$field $idx" - #what happens to $refindices??? - - - #!todo varspace - - if {![llength $refindices]} { - #puts stdout "\t 1a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - - if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { - unset ::p::${OID}::o_${prop}($idx) - } else { - ::p::${IID}::_iface::(UNSET)$prop $_ID_ $idx - } - - - #manually call refsync, passing it this refvar as an exclusion - ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $idx - } else { - #assert - won't get here - error 1a - - } - - } else { - if {[llength $refindices]} { - #error 2a - #puts stdout "\t 2a@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - - if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { - #review - what about list-type property? - #if {[array exists ::p::${OID}::o_${prop}]} ??? - unset ::p::${OID}::o_${prop}($refindices) - } else { - ::p::${IID}::_iface::(UNSET)$prop $_ID_ $refindices - } - - - - #manually call refsync, passing it this refvar as an exclusion - ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} $refindices - - - } else { - #puts stdout "\t 2b@@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - - #ref is not of form prop+x etc and no idx in the trace - this is a plain unset - if {![llength [info commands ::p::${IID}::_iface::(UNSET)$prop]]} { - unset ::p::${OID}::o_${prop} - } else { - ::p::${IID}::_iface::(UNSET)$prop $_ID_ "" - } - #manually call refsync, passing it this refvar as an exclusion - ::p::predator::refsyncvar_unset_manualupdate $OID $refname $prop ::p::${OID}::o_${prop} {} - - } - } - - - - - } errM]} { - #set ::LAST_UNSET_ERROR "$errM\n[set ::errorInfo]" - set ruler [string repeat - 80] - puts stderr "\t$ruler" - puts stdout "\t @@@@ERROR propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - puts stderr "\t$ruler" - puts stderr $errM - puts stderr "\t$ruler" - - } else { - #puts stdout "\t @@@@ propref_trace_unset $OID ref:'$refname' var:'$vref' idx:'$idx'" - #puts stderr "*@*@*@*@ end propref_trace_unset - no error" - } - - trace add variable ::p::${OID}::o_${prop} [::list unset] [::list ::p::predator::propvar_unset_TraceHandler $OID $prop] - - -} - - - - -proc ::p::predator::refsyncvar_unset_manualupdate {OID triggeringRef prop vtraced vidx} { - - #Do not use 'info exists' (avoid triggering read trace) - use info vars - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - #puts " **> lappending '::p::REF::${OID}::$prop'" - lappend refvars ::p::${OID}::_ref::$prop - } - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] - - - - if {[string length $triggeringRef]} { - set idx [lsearch -exact $refvars $triggeringRef] - if {$idx >= 0} { - set refvars [lreplace $refvars[set refvars {}] $idx $idx] ;#note inline K combinator [set refvars {}] - } - } - if {![llength $refvars]} { - #puts stderr " %%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . $OID $triggeringRef $prop $vtraced $vidx" - return - } - - - #*usually* triggeringRef is not in the reflist because the triggeringRef is being unset - # - but this is not the case when we do an array unset of an element using a reference to the whole array e.g "array unset [>obj . arr .] b" - if {([string length $triggeringRef]) && ($triggeringRef in $refvars)} { - #puts stderr "\t@@@@@@@@@@ propvar_unset_TraceHandler unexpected situation. triggeringRef $triggeringRef in refvars:$refvars during unset ???" - puts stderr "\t@@@@@ propvar_unset_TraceHandler triggeringRef $triggeringRef is in refvars list - probably a call of form 'array unset \[>obj .arr .\] someindex'" - } - - - puts stderr "\t refsyncvar_unset_manualupdate OID:'$OID' triggeringRef:'$triggeringRef' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' " - - - - upvar $vtraced SYNCVARIABLE - - - #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars - array set traces [::list] - - #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" - - - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - if {$ops in {read write unset array}} { - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } - } - } - } - - - - - if {[array exists SYNCVARIABLE]} { - - #underlying variable is an array - we are presumably unsetting just an element - set vtracedIsArray 1 - } else { - #!? maybe the var was an array - but it's been unset? - set vtracedIsArray 0 - } - - #puts stderr "--------------------------------------------------\n\n" - #some things we don't want to repeat for each refvar in case there are lots of them.. - - #set triggeringRefIdx $vidx - - if {[string match "${prop}+*" [namespace tail $triggeringRef]]} { - set triggering_indices [lrange [split [namespace tail $triggeringRef] +] 1 end] - } else { - set triggering_indices [list] - } - - - - - #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" - #puts stderr ">>> [trace info variable $vtraced]" - #puts "--- unset branch refvar:$refvar" - - - - if {[llength $vidx]} { - #trace called with an index - must be an array - foreach refvar $refvars { - set reftail [namespace tail $refvar] - - if {[string match "${prop}+*" $reftail]} { - #!todo - add test - if {$vidx eq [lrange [split $reftail +] 1 end]} { - #unset if indices match - error "untested, possibly unused branch spuds1" - #puts "1111111111111111111111111" - unset $refvar - } - } else { - #test exists - #!todo - document which one - - #see if we succeeded in unsetting this element in the underlying variables - #(may have been blocked by a PropertyUnset body) - set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] - #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" - if {$element_exists} { - #do nothing it wasn't actually unset - } else { - #puts "JJJJJ unsetting ${refvar}($vidx)" - unset ${refvar}($vidx) - } - } - } - - - - - - } else { - - foreach refvar $refvars { - set reftail [namespace tail $refvar] - - if {[string match "${prop}+*" $reftail]} { - #check indices of triggering refvar match this refvars indices - - - if {$reftail eq [namespace tail $triggeringRef]} { - #!todo - add test - error "untested, possibly unused branch spuds2" - #puts "222222222222222222" - unset $refvar - } else { - - #error "untested - branch spuds2a" - - - } - - } else { - #!todo -add test - #reference is directly to property var - error "untested, possibly unused branch spuds3" - #theoretically no other non-indexed ref.. so $triggeringRefIdx must contain non-zero-len string? - puts "\t33333333333333333333" - - if {[string length $triggeringRefIdx]} { - unset $refvar($triggeringRefIdx) - } - } - } - - } - - - - - #!todo - understand. - #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" - #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) - - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names traces] { - foreach tinfo $traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" - trace add variable $rv $ops $cmd - } - } - - - - - -} - - -proc ::p::predator::propvar_unset_TraceHandler {OID prop vtraced vidx op} { - - upvar $vtraced SYNCVARIABLE - - set refvars [::list] - #Do not use 'info exists' (avoid triggering read trace) - use info vars - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - lappend refvars ::p::${OID}::_ref::$prop - } - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] - - - - #short_circuit breaks unset traces for array elements (why?) - - - if {![llength $refvars]} { - #puts stderr "\t%%%%%%%%%% no refvars for propvar_unset_TraceHandler to update - short circuiting . OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" - return - } else { - puts stderr "\t****** [llength $refvars] refvars for propvar_unset_TraceHandler to update. OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx'" - } - - if {[catch { - - - - #We are only interested in suppressing the 'setGet_TraceHandler' traces on refvars - array set traces [::list] - - #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" - - - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - if {$ops in {read write unset array}} { - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } - } - } - } - - - - - if {[array exists SYNCVARIABLE]} { - - #underlying variable is an array - we are presumably unsetting just an element - set vtracedIsArray 1 - } else { - #!? maybe the var was an array - but it's been unset? - set vtracedIsArray 0 - } - - #puts stderr "--------------------------------------------------\n\n" - #some things we don't want to repeat for each refvar in case there are lots of them.. - set triggeringRefIdx $vidx - - - - #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" - #puts stderr ">>> [trace info variable $vtraced]" - #puts "--- unset branch refvar:$refvar" - - - - if {[llength $vidx]} { - #trace called with an index - must be an array - foreach refvar $refvars { - set reftail [namespace tail $refvar] - - if {[string match "${prop}+*" $reftail]} { - #!todo - add test - if {$vidx eq [lrange [split $reftail +] 1 end]} { - #unset if indices match - error "untested, possibly unused branch spuds1" - #puts "1111111111111111111111111" - unset $refvar - } - } else { - #test exists - #!todo - document which one - - #see if we succeeded in unsetting this element in the underlying variables - #(may have been blocked by a PropertyUnset body) - set element_exists [uplevel 1 [::list info exists ${vtraced}($vidx)]] - #puts "JJJJJJ vtraced:$vtraced vidx:$vidx element_exists:$element_exists" - if {$element_exists} { - #do nothing it wasn't actually unset - } else { - #puts "JJJJJ unsetting ${refvar}($vidx)" - unset ${refvar}($vidx) - } - } - } - - - - - - } else { - - foreach refvar $refvars { - set reftail [namespace tail $refvar] - unset $refvar - - } - - } - - - - - #!todo - understand. - #puts stderr "\n*****\n propvar_unset_TraceHandler $refvar unset $prop $args \n*****\n" - #catch {unset $refvar} ;#oops - Tcl_EventuallyFree called twice - abnormal program termination (tcl8.4?) - - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names traces] { - foreach tinfo $traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing setGet trace '$ops' on variable $rv" - trace add variable $rv $ops $cmd - } - } - - } errM]} { - set ruler [string repeat * 80] - puts stderr "\t$ruler" - puts stderr "\t>>>>>>>$ propvar_unset_TraceHandler OID:'$OID' prop:'$prop' vtraced:'$vtraced' vidx:'$vidx' $op" - puts stderr "\t$ruler" - puts stderr $::errorInfo - puts stderr "\t$ruler" - - } - -} - -proc ::p::predator::refsyncvar_write_manualupdate {OID triggeringRef prop vtraced indices} { - error hmmmmm - upvar $vtraced SYNCVARIABLE - #puts stderr "\t>>>>>>>$ refsyncvar_write_manualupdate $OID '$triggeringRef' '$prop' vtraced:'$vtraced' indices:'$indices' " - set refvars [::list] - - #avoid info exists ::p::${OID}::_ref::$prop (info exists triggers read unnecessary read trace ) - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) - } - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references - #assert triggeringRef is in the list - if {([string length $triggeringRef]) && ($triggeringRef ni $refvars)} { - error "@@@@@@@@@@ refsyncvar_write_manualupdate unexpected situation. triggeringRef $triggeringRef ni refvars:$refvars" - } - set refposn [lsearch -exact $refvars $triggeringRef] - #assert - due to test above, we know $triggeringRef is in the list so refposn > 0 - set refvars [lreplace $refvars[set refvars {}] $refposn $refposn] ;#note inline K combinator [set refvars {}] - if {![llength $refvars]} { - #puts stderr " %%%%%%%%%% no refvars for refsyncvar_write_manualupdate to update - short circuiting . OID:$OID prop:$prop" - return [list refs_updates [list]] - } - - #suppress the propref_trace_* traces on all refvars - array set traces [::list] - array set external_traces [::list] ;#e.g application/3rd party traces on "">obj . prop ." - #we do not support tracing of modifications to refs which occur from inside the pattern system. ie we disable them during refsync - #todo - after finished refsyncing - consider manually firing the external_traces in such a way that writes/unsets raise an error? - #(since an external trace should not be able to affect a change which occured from inside the object - but can affect values from application writes/unsets to the ref) - - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - - - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } else { - #all other traces are 'external' - lappend external_traces($rv) $tinfo - #trace remove variable $rv $ops $cmd - } - - } - } - #-------------------------------------------------------------------------------------------------------------------------- - if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { - if {![info exists SYNCVARIABLE]} { - error "WARNING: REVIEW why does $vartraced not exist here?" - } - #either the underlying variable is an array - # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern - set treat_vtraced_as_array 1 - } else { - set treat_vtraced_as_array 0 - } - - set refs_updated [list] - set refs_deleted [list] ;#unset due to index no longer being relevant - if {$treat_vtraced_as_array} { - foreach refvar $refvars { - #puts stdout "\n\n \tarrayvariable:'$vtraced' examining REFVAR:'$refvar'" - set refvar_tail [namespace tail $refvar] - if {[string match "${prop}+*" $refvar_tail]} { - #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y - set ref_indices [lrange [split $refvar_tail +] 1 end] - if {[llength $indices]} { - if {[llength $indices] == 1} { - if {[lindex $ref_indices 0] eq [lindex $indices 0]} { - #error "untested xxx-a" - set ${refvar} [set SYNCVARIABLE([lindex $indices 0])] - lappend refs_updated $refvar - } else { - #test exists - #error "xxx-ok single index" - #updating a different part of the property - nothing to do - } - } else { - #nested index - if {[lindex $ref_indices 0] eq [lindex $indices 0]} { - if {[llength $ref_indices] == 1} { - #error "untested xxx-b1" - set ${refvar} [lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end] ] - } else { - #assert llength $ref_indices > 1 - #NOTE - we cannot test index equivalence reliably/simply just by comparing indices - #compare by value - - if {![catch {lindex [set SYNCVARIABLE([lindex $indices 0])] [lrange $indices 1 end]} possiblyNewVal]} { - #puts stderr "\tYYYYYYYYY $refvar:'[set $refvar]'' / possiblyNewVal:'$possiblyNewVal'" - if {[set $refvar] ne $possiblyNewVal} { - set $refvar $possiblyNewVal - } - } else { - #fail to retrieve underlying value corrsponding to these $indices - unset $refvar - } - } - } else { - #test exists - #error "untested xxx-ok deepindex" - #updating a different part of the property - nothing to do - } - } - } else { - error "untested xxx-c" - - } - - } else { - #refvar to update is plain e.g ::p::${OID}::_ref::${prop} - if {[llength $indices]} { - if {[llength $indices] == 1} { - set ${refvar}([lindex $indices 0]) [set SYNCVARIABLE([lindex $indices 0])] - } else { - lset ${refvar}([lindex $indices 0]) {*}[lrange $indices 1 end] [lindex [set SYNCVARIABLE([lindex $indices 0])] {*}[lrange $indices 1 end]] - } - lappend refs_updated $refvar - } else { - error "untested yyy" - set $refvar $SYNCVARIABLE - } - } - } - } else { - #vtraced non array, but could be an array element e.g ::p::${OID}::_ref::ARR(x) - # - foreach refvar $refvars { - #puts stdout "\n\n \tsimplevariable:'$vtraced' examining REFVAR:'$refvar'" - set refvar_tail [namespace tail $refvar] - if {[string match "${prop}+*" $refvar_tail]} { - #refvar to update is curried e.g ::p::${OID}::_ref::${prop}+x+y - set ref_indices [lrange [split $refvar_tail +] 1 end] - - if {[llength $indices]} { - #see if this update would affect this curried ref - #1st see if we can short-circuit our comparison based on numeric-indices - if {[string is digit -strict [join [concat $ref_indices $indices] ""]]} { - #both sets of indices are purely numeric (no end end-1 etc) - set rlen [llength $ref_indices] - set ilen [llength $indices] - set minlen [expr {min($rlen,$ilen)}] - set matched_firstfew_indices 1 ;#assume the best - for {set i 0} {$i < $minlen} {incr i} { - if {[lindex $ref_indices $i] ne [lindex $indices $i]} { - break ;# - } - } - if {!$matched_firstfew_indices} { - #update of this refvar not required - #puts stderr "\t@@@1 SKIPPING refvar $refvar - indices don't match $ref_indices vs $indices" - break ;#break to next refvar in the foreach loop - } - } - #failed to short-circuit - - #just do a simple value comparison - some optimisations are possible, but perhaps unnecessary here - set newval [lindex $SYNCVARIABLE $ref_indices] - if {[set $refvar] ne $newval} { - set $refvar $newval - lappend refs_updated $refvar - } - - } else { - #we must be updating the entire variable - so this curried ref will either need to be updated or unset - set newval [lindex $SYNCVARIABLE $ref_indices] - if {[set ${refvar}] ne $newval} { - set ${refvar} $newval - lappend refs_updated $refvar - } - } - } else { - #refvar to update is plain e.g ::p::${OID}::_ref::${prop} - if {[llength $indices]} { - #error "untested zzz-a" - set newval [lindex $SYNCVARIABLE $indices] - if {[lindex [set $refvar] $indices] ne $newval} { - lset ${refvar} $indices $newval - lappend refs_updated $refvar - } - } else { - if {[set ${refvar}] ne $SYNCVARIABLE} { - set ${refvar} $SYNCVARIABLE - lappend refs_updated $refvar - } - } - - } - - } - } - #-------------------------------------------------------------------------------------------------------------------------- - - #!todo - manually fire $external_traces as appropriate - but somehow raise error if attempt to write/unset - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names traces] { - if {$rv ni $refs_deleted} { - foreach tinfo $traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" - trace add variable $rv $ops $cmd - } - } - } - foreach rv [array names external_traces] { - if {$rv ni $refs_deleted} { - foreach tinfo $external_traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - #trace add variable $rv $ops $cmd - } - } - } - - - return [list updated_refs $refs_updated] -} - -#purpose: update all relevant references when context variable changed directly -proc ::p::predator::propvar_write_TraceHandler {OID prop vtraced vidx op} { - #note that $vtraced may have been upvared in calling scope - so could have any name! only use it for getting/setting values - don't rely on it's name in any other way. - #we upvar it here instead of using uplevel - as presumably upvar is more efficient (don't have to wory about whether uplevelled script is bytecompiled etc) and also makes code simpler - - upvar $vtraced SYNCVARIABLE - #puts stderr "\t>>>>>>>$ propvar_write_TraceHandler OID:$OID propertyname:'$prop' vtraced:'$vtraced' index:'$vidx' operation:$op" - set t_info [trace vinfo $vtraced] - foreach t_spec $t_info { - set t_ops [lindex $t_spec 0] - if {$op in $t_ops} { - puts stderr "\t!!!!!!!! propvar_write_Tracehandler [lindex $t_spec 1]" - } - } - - #puts stderr -*-*-[info vars ::p::_ref::${OID}::[lindex $prop 0]+*]-*-*- - #vtype = array | array-item | list | simple - - set refvars [::list] - - ############################ - #!!!NOTE!!! do not call 'info exists' on a propref here as it will trigger a read trace -which then pulls in the value from the (GET)prop function etc!!! - #This would be extra cpu work - and sets the propref prematurely (breaking proper property-trace functionality plus vwaits on proprefs) - #The alternative 'info vars' does not trigger traces - if {[info vars ::p::${OID}::_ref::$prop] eq "::p::${OID}::_ref::$prop"} { - #puts " **> lappending '::p::REF::${OID}::$prop'" - lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) - } - ############################ - - #lappend refvars ::p::${OID}::_ref::$prop ;#this is the basic unindexed reference we normally get when getting a standard property ref (e.g set ref [>obj . prop .]) - lappend refvars {*}[info vars ::p::${OID}::_ref::${prop}+*] ;#add any indexed references - - - if {![llength $refvars]} { - #puts stderr "\t%%%%%%%%%% no refvars for propvar_write_TraceHandler to update - short circuiting . OID:$OID prop:$prop" - return - } - - - #puts stderr "*-*-*-*-*-* refvars \n- [join $refvars "\n- "]" - - #We are only interested in suppressing the pattern library's 'propref_trace_*' traces and 3rd party 'read' traces on refvars - array set predator_traces [::list] - #maintain two lists of external traces - as we need to temporarily deactivate all non-pattern read traces even if they are part of a more comprehensive trace.. - #ie for something like 'trace add variable someref {write read array} somefunc' - # we need to remove and immediately reinstall it as a {write array} trace - and at the end of this procedure - reinstall it as the original {write read array} trace - array set external_read_traces [::list] ;#pure read traces the library user may have added - array set external_readetc_traces [::list] ;#read + something else traces the library user may have added - foreach rv $refvars { - #puts "--refvar $rv" - foreach tinfo [trace info variable $rv] { - #puts "##trace $tinfo" - set ops {}; set cmd {} - lassign $tinfo ops cmd - #!warning - assumes traces with single operation per handler. - #write & unset traces on refvars need to be suppressed - #we also need to be able to read certain refvars without triggering retrieval of underlying value in order to detect if changed. - #if {$ops in {read write unset array}} {} - - if {[string match "::p::predator::propref_trace_*" $cmd]} { - lappend predator_traces($rv) $tinfo - trace remove variable $rv $ops $cmd - #puts stderr "*-*-*-*-*-* removing $ops trace on $rv -> $cmd" - } else { - #other traces - # puts "##trace $tinfo" - if {"read" in $ops} { - if {[llength $ops] == 1} { - #pure read - - lappend external_read_traces($rv) $tinfo - trace remove variable $rv $ops $cmd - } else { - #mixed operation trace - remove and reinstall without the 'read' - lappend external_readetc_traces($rv) $tinfo - set other_ops [lsearch -all -inline -not $ops "read"] - trace remove variable $rv $ops $cmd - #reinstall trace for non-read operations only - trace add variable $rv $other_ops $cmd - } - } - } - } - } - - - if {([array exists SYNCVARIABLE]) || (![info exists SYNCVARIABLE])} { - #either the underlying variable is an array - # OR - underlying variable doesn't exist - so we treat the property as an array because of the indexed access pattern - set vtracedIsArray 1 - } else { - set vtracedIsArray 0 - } - - #puts stderr "--------------------------------------------------\n\n" - - #puts stderr ">>>...----refsync-trace = $vtraced $op refvars:$refvars" - #puts stderr ">>> [trace info variable $vtraced]" - #puts "**write*********** propvar_write_TraceHandler $prop $vtraced $vidx $op" - #puts "**write*********** refvars: $refvars" - - #!todo? unroll foreach into multiple foreaches within ifs? - #foreach refvar $refvars {} - - - #puts stdout "propvar_write_TraceHandler examining REFVAR $refvar" - if {[string length $vidx]} { - #indexable - if {$vtracedIsArray} { - - foreach refvar $refvars { - #puts stderr " - - a refvar $refvar vidx: $vidx" - set tail [namespace tail $refvar] - if {[string match "${prop}+*" $tail]} { - #refvar is curried - #only set if vidx matches curried index - #!todo -review - set idx [lrange [split $tail +] 1 end] - if {$idx eq $vidx} { - set newval [set SYNCVARIABLE($vidx)] - if {[set $refvar] ne $newval} { - set ${refvar} $newval - } - #puts stderr "=a.1=> updated $refvar" - } - } else { - #refvar is simple - set newval [set SYNCVARIABLE($vidx)] - if {![info exists ${refvar}($vidx)]} { - #new key for this array - #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " - array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] - } else { - set oldval [set ${refvar}($vidx)] - if {$oldval ne $newval} { - #puts stderr "\npropvar_write_TraceHandler------ about to call 'array set $refvar [::list $vidx [set SYNCVARIABLE($vidx)] ]' " - array set ${refvar} [::list $vidx [set SYNCVARIABLE($vidx)] ] - } - } - #puts stderr "=a.2=> updated ${refvar} $vidx" - } - } - - - - } else { - - - foreach refvar $refvars { - upvar $refvar internal_property_reference - #puts stderr " - - b vidx: $vidx" - - #!? could be object not list?? - #!!but what is the difference between an object, and a list of object names which happens to only contain one object?? - #For predictability - we probably need to autodetect type on 1st write to o_prop either list, array or object (and maintain after unset operations) - #There would still be an edge case of an initial write of a list of objects of length 1. - if {([llength [set $SYNCVARIABLE]] ==1) && ([string range [set $SYNCVARIABLE] 0 0] eq ">")} { - error "untested review!" - #the o_prop is object-shaped - #assumes object has a defaultmethod which accepts indices - set newval [[set $SYNCVARIABLE] {*}$vidx] - - } else { - set newval [lindex $SYNCVARIABLE {*}$vidx] - #if {[set $refvar] ne $newval} { - # set $refvar $newval - #} - if {$internal_property_reference ne $newval} { - set internal_property_reference $newval - } - - } - #puts stderr "=b=> updated $refvar" - } - - - } - - - - } else { - #no vidx - - if {$vtracedIsArray} { - - - foreach refvar $refvars { - set targetref_tail [namespace tail $refvar] - set targetref_is_indexed [string match "${prop}+*" $targetref_tail] - - - #puts stderr " - - c traced: $vtraced refvar:$refvar triggeringRef: $triggeringRef" - if {$targetref_is_indexed} { - #curried array item ref of the form ${prop}+x or ${prop}+x+y etc - - #unindexed write on a property that is acting as an array.. - - #case a) If the underlying variable is actually an array - it will error upon attempt to write it like this - that's ok. - - #case b) If the underlying variable doesn't exist - perhaps a PropertyWrite will accept the unindexed write (e.g by asigning a default for the missing index). - # we can't know here how this write affects other indexed traces on this property... hence we warn but do nothing. - puts stderr "\tc.1 WARNING: write to property without 'array set'. op:'$op' refvar:'$refvar' prop:'$prop' \n\traw: propvar_write_TraceHandler $OID $prop $vtraced $vidx $op" - } else { - #How do we know what to write to array ref? - puts stderr "\tc.2 WARNING: unimplemented/unused?" - #error no_tests_for_branch - - #warning - this would trigger 3rd party unset traces which is undesirable for what is really a 'bookkeeping' operation - #if this branch is actually useful - we probably need to step through the array and unset and set elements as appropriate - array unset ${refvar} - array set ${refvar} [array get SYNCVARIABLE] - } - } - - - - } else { - foreach refvar $refvars { - #puts stderr "\t\t_________________[namespace current]" - set targetref_tail [namespace tail $refvar] - upvar $refvar INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail - set targetref_is_indexed [string match "${prop}+*" $targetref_tail] - - if {$targetref_is_indexed} { - #puts "XXXXXXXXX vtraced:$vtraced" - #reference curried with index(es) - #we only set indexed refs if value has changed - # - this not required to be consistent with standard list-containing variable traces, - # as normally list elements can't be traced seperately anyway. - # - - - #only bother checking a ref if no setVia index - # i.e some operation on entire variable so need to test synchronisation for each element-ref - set targetref_indices [lrange [split $targetref_tail +] 1 end] - set possiblyNewVal [lindex $SYNCVARIABLE {*}$targetref_indices] - #puts stderr "YYYYYYYYY \[set \$refvar\]: [set $refvar] / possiblyNewVal: $possiblyNewVal" - if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $possiblyNewVal} { - set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $possiblyNewVal - #puts stderr "=d1=> updated $refvar -> [uplevel 1 "lindex \[set $vtraced] $idx"]" - } - - - } else { - #for consistency with standard traces on a list-containing variable, we perform the set even if the list value has not changed! - - #puts stderr "- d2 set" - #puts "refvar: [set $refvar]" - #puts "SYNCVARIABLE: $SYNCVARIABLE" - - #if {[set $refvar] ne $SYNCVARIABLE} { - # set $refvar $SYNCVARIABLE - #} - if {[set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail] ne $SYNCVARIABLE} { - set INTERNAL_REFERENCE_TO_PROPERTY__$targetref_tail $SYNCVARIABLE - } - - } - } - - - } - - } - - - - - #reinstall the traces we stored at the beginning of this proc. - foreach rv [array names predator_traces] { - foreach tinfo $predator_traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" - trace add variable $rv $ops $cmd - } - } - - foreach rv [array names external_traces] { - foreach tinfo $external_traces($rv) { - set ops {}; set cmd {} - lassign $tinfo ops cmd - - #puts stderr "****** re-installing trace '$ops' on variable $rv cmd:$cmd" - trace add variable $rv $ops $cmd - } - } - - - -} - -# end propvar_write_TraceHandler - - - - - - - - - - - - - - - - -# - -#returns 0 if method implementation not present for interface -proc ::p::predator::method_chainhead {iid method} { - #Interface proc - # examine the existing command-chain - set candidates [info commands ::p::${iid}::_iface::$method.*] ;#rough grab (info commands only allows basic pattern globbing - not a regex) - set cmdchain [list] - - set re [string map [list %m% [string map {( \\( ) \\) . \\.} $method]] {^%m%.([0-9]+)$}] - set maxversion 0 - #loop and test because it is possible there are unrelated commands (having a matching prefix with . character) which were caught in the glob. - foreach test [lsort -dictionary $candidates] { - set c [namespace tail $test] - if {[regexp $re $c _match version]} { - lappend cmdchain $c - if {$version > $maxversion} { - set maxversion $version - } - } - } - return $maxversion -} - - - - - -#this returns a script that upvars vars for all interfaces on the calling object - -# - must be called at runtime from a method -proc ::p::predator::upvar_all {_ID_} { - #::set OID [lindex $_ID_ 0 0] - ::set OID [::lindex [::dict get $_ID_ i this] 0 0] - ::set decl {} - #[set ::p::${OID}::_meta::map] - #[dict get [lindex [dict get $_ID_ i this] 0 1] map] - - ::upvar #0 ::p::${OID}::_meta::map MAP - #puts stdout "\n\n -->-->-->--> _meta::map '$MAP' <-<-<-\n\n" - #set iflist [::lindex [dict get [lindex [dict get $_ID_ i this] 0 1] map] 1 0] - - ::foreach ifid [dict get $MAP interfaces level0] { - if {[::dict size [::set ::p::${ifid}::_iface::o_variables]]} { - ::array unset nsvars - ::array set nsvars [::list] - ::dict for {vname vinfo} [::set ::p::${ifid}::_iface::o_variables] { - ::set varspace [::dict get $vinfo varspace] - ::lappend nsvars($varspace) $vname - } - #nsvars now contains vars grouped by varspace. - - ::foreach varspace [::array names nsvars] { - if {$varspace eq ""} { - ::set ns ::p::${OID} - } else { - if {[::string match "::*" $varspace]} { - ::set ns $varspace - } else { - ::set ns ::p::${OID}::$varspace - } - } - - ::append decl "namespace upvar $ns " - ::foreach vname [::set nsvars($varspace)] { - ::append decl "$vname $vname " - } - ::append decl " ;\n" - } - ::array unset nsvars - } - } - ::return $decl -} - -#we need to use eval because it is potentially a multiline script returned by upvar_all (so can't just use {*} operator) -proc ::p::predator::runtime_vardecls {} { - set result "::eval \[::p::predator::upvar_all \$_ID_\]" - #set result "::apply { {_ID_} ::p::predator::upvar_all } \$_ID_" - - #set result "::apply \[::list {} \[::p::predator::upvar_all \$_ID_\] \[namespace current\]\]" - #set result "::interp eval {} \[::p::predator::upvar_all \$_ID_\]" - #puts stdout "\t>>>[info level -1]\n\t>>>>>>>>>>>>>>>>>>>>> '$result'" - return $result -} - - - - - - -#OBSOLETE!(?) - todo - move stuff out of here. -proc ::p::predator::compile_interface {IFID caller_ID_} { - upvar 0 ::p::${IFID}:: IFACE - - #namespace eval ::p::${IFID} { - # namespace ensemble create - #} - - #'namespace upvar' - from tip.tcl.tk #250: Efficient Access to Namespace Variables - - namespace upvar ::p::${IFID}::_iface o_propertyunset_handlers o_propertyunset_handlers o_variables o_variables o_properties o_properties o_methods o_methods o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces - - #set varDecls {} - #if {[llength $o_variables]} { - # #puts "*********!!!! $vlist" - # append varDecls "namespace upvar ::p::\[lindex \$_ID_ 0 0 \] " - # foreach vdef $o_variables { - # append varDecls "[lindex $vdef 0] [lindex $vdef 0] " - # } - # append varDecls \n - #} - - #runtime gathering of vars from other interfaces. - #append varDecls [runtime_vardecls] - - set varDecls [runtime_vardecls] - - - - #implement methods - - #!todo - avoid globs on iface array? maintain list of methods in another slot? - #foreach {n mname} [array get IFACE m-1,name,*] {} - - - #namespace eval ::p::${IFID}::_iface "namespace export {*}$o_methods" ;#make methods available as interface ensemble. - - - - #implement property getters/setters/unsetters - #'setter' overrides - #pw short for propertywrite - foreach {n property} [array get IFACE pw,name,*] { - if {[string length $property]} { - #set property [lindex [split $n ,] end] - - #!todo - next_script - #set next [::p::next_script "\[set ::p::\${_ID_}::(self)]" $IFID $property] - - set maxversion [::p::predator::method_chainhead $IFID (SET)$property] - set chainhead [expr {$maxversion + 1}] - set THISNAME (SET)$property.$chainhead ;#first version will be (SET)$property.1 - - set next [::p::predator::next_script $IFID (SET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ?? - - set body $IFACE(pw,body,$property) - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set body $varDecls\n[dict get $processed body] - #puts stderr "\t\timplicit vardecls used for propertywrite $property on interface $IFID ##### \n $body" - } - - #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3 \]" @next@ $next] $body\n] - 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 maxversion [::p::predator::method_chainhead $IFID $property] - set headid [expr {$maxversion + 1}] - - proc ::p::${IFID}::_iface::(SET)$property.$headid [concat _ID_ $IFACE(pw,arg,$property)] $body - - interp alias {} ::p::${IFID}::_iface::(SET)$property {} ::p::${IFID}::_iface::(SET)$property.$headid - - #proc ::p::${IFID}::___system___write_$property [concat _ID_ $IFACE(pw,arg,$property)] $body - } - } - #'unset' overrides - - dict for {property handler_info} $o_propertyunset_handlers { - - set body [dict get $handler_info body] - set arraykeypattern [dict get $handler_info arraykeypattern] ;#array element pattern for unsetting individual elements in an array - - set maxversion [::p::predator::method_chainhead $IFID (UNSET)$property] - set headid [expr {$maxversion + 1}] - - set THISNAME (UNSET)$property.$headid - - set next [::p::predator::next_script $IFID (UNSET)$property $THISNAME $caller_ID_] ;#?! caller_ID_ ??? - - - - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set body $varDecls\n[dict get $processed body] - #puts stderr "\t\timplicit vardecls used for property unset $property on interface $IFID ##### \n $body" - - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - 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] - - - - - #implement - #always take arraykeypattern argument even though usually empty string (only used for unsetting individual array elements) - if {[string trim $arraykeypattern] eq ""} { - set arraykeypattern "_dontcare_" - } - proc ::p::${IFID}::_iface::(UNSET)$property.$headid [concat _ID_ $arraykeypattern] $body - - - #chainhead pointer - interp alias {} ::p::${IFID}::_iface::(UNSET)$property {} ::p::${IFID}::_iface::(UNSET)$property.$headid - } - - - - interp alias {} ::p::${IFID}::(VIOLATE) {} ::p::internals::(VIOLATE) - - #the usual case will have no destructor - so use info exists to check. - - if {[info exists ::p::${IFID}::_iface::o_destructor_body]} { - #!todo - chained destructors (support @next@). - #set next [::p::next_script_destructor "\[lindex \$_ID_ 0 1\]" $IFID] - set next NEXT - - set body [set ::p::${IFID}::_iface::o_destructor_body] - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set body $varDecls\n[dict get $processed body] - #puts stderr "\t\t**********************implicit vardecls used for destructor on interface $IFID ##### \n $body" - } - #set body [::p::fixed_var_statements \n@IMPLICITDECLS@\n$body] - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - 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] - - - proc ::p::${IFID}::___system___destructor _ID_ $body - } - - - if {[info exists o_unknown]} { - #use 'apply' somehow? - interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown - - #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] - } - - - return -} - - - - - - - -#'info args' - assuming arbitrary chain of 'interp aliases' -proc ::p::predator::command_info_args {cmd} { - if {[llength [set next [interp alias {} $cmd]]]} { - set curriedargs [lrange $next 1 end] - - if {[catch {set arglist [info args [lindex $next 0]]}]} { - set arglist [command_info_args [lindex $next 0]] - } - #trim curriedargs - return [lrange $arglist [llength $curriedargs] end] - } else { - info args $cmd - } -} - - -proc ::p::predator::do_next {_ID_ IFID mname nextArgs args} { - if {[llength $args]} { - tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$args - } else { - if {[llength $nextArgs] > 1} { - set argVals [::list] - set i 0 - foreach arg [lrange $nextArgs 1 end] { - upvar 1 $arg $i - if {$arg eq "args"} { - #need to check if 'args' is actually available in caller - if {[info exists $i]} { - set argVals [concat $argVals [set $i]] - } - } else { - lappend argVals [set $i] - } - } - tailcall ::p::${IFID}::_iface::$mname $_ID_ {*}$argVals - } else { - tailcall ::p::${IFID}::_iface::$mname $_ID_ - } - } -} - -#---------------------------------------------------------------------------------------------- -proc ::p::predator::next_script {IFID method caller caller_ID_} { - - if {$caller eq "(CONSTRUCTOR).1"} { - return [string map [list %cID% [list $caller_ID_] %ifid% $IFID %m% $method] {::p::predator::do_next_pattern_if $_ID_ %cID% %ifid% %m%}] - } elseif {$caller eq "$method.1"} { - #delegate to next interface lower down the stack which has a member named $method - return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] - } elseif {[string match "(GET)*.2" $caller]} { - # .1 is the getprop procedure, .2 is the bottom-most PropertyRead. - - #jmn - set prop [string trimright $caller 1234567890] - set prop [string range $prop 5 end-1] ;#string leading (GET) and trailing . - - if {$prop in [dict keys [set ::p::${IFID}::_iface::o_properties]]} { - #return [string map [list %ifid% $IFID %p% $prop ] {::p::%ifid%::_iface::(GET)%p%.1 $_ID_}] - return [string map [list %ifid% $IFID %m% (GET)$prop.1 %nargs% [list]] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] - } else { - #we can actually have a property read without a property or a method of that name - but it could also match the name of a method. - # (in which case it could return a different value depending on whether called via set [>obj . something .] vs >obj . something) - return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] - } - } elseif {[string match "(SET)*.2" $caller]} { - return [string map [list %ifid% $IFID %m% $method] {::p::predator::do_next_if $_ID_ %ifid% %m%}] - } else { - #this branch will also handle (SET)*.x and (GET)*.x where x >2 - - #puts stdout "............next_script IFID:$IFID method:$method caller:$caller" - set callerid [string range $caller [string length "$method."] end] - set nextid [expr {$callerid - 1}] - - if {[catch {set nextArgs [info args ::p::${IFID}::_iface::$method.$nextid]} errMsg]} { - #not a proc directly on this interface - presumably an alias made by something like linkcopy_interface. - #puts ">>>>>>>>::p::predator::next_script IFID:$IFID caller:$caller aaaa@ $method.$nextid" - set nextArgs [command_info_args ::p::${IFID}::_iface::$method.$nextid] - } - - return [string map [list %ifid% $IFID %m% $method.$nextid %nargs% $nextArgs] {::p::predator::do_next $_ID_ %ifid% %m% [list %nargs%]}] - } -} - -proc ::p::predator::do_next_if {_ID_ IFID method args} { - #puts "<>(::p::predator::do_next_if)<> '$_ID_' '$IFID' '$method' '$args' (((" - - #set invocants [dict get $_ID_ i] - #set this_invocantdata [lindex [dict get $invocants this] 0] - #lassign $this_invocantdata OID this_info - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set interfaces [dict get $MAP interfaces level0] - set patterninterfaces [dict get $MAP interfaces level1] - - set L0_posn [lsearch $interfaces $IFID] - if {$L0_posn == -1} { - error "(::p::predator::do_next_if) called with interface not present at level0 for this object" - } elseif {$L0_posn > 0} { - #set ifid_next [lindex $interfaces $L0_posn-1] ;#1 lower in the iStack - set lower_interfaces [lrange $interfaces 0 $L0_posn-1] - - foreach if_sub [lreverse $lower_interfaces] { - if {[string match "(GET)*" $method]} { - #do not test o_properties here! We need to call even if there is no underlying property on this interface - #(PropertyRead without Property is legal. It results in dispatch to subsequent interface rather than property variable for this interface) - # relevant test: higher_order_propertyread_chaining - return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] - } elseif {[string match "(SET)*" $method]} { - #must be called even if there is no matching $method in o_properties - return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] - } elseif {[string match "(UNSET)*" $method]} { - #review untested - #error "do_next_if (UNSET) untested" - #puts stderr "<>(::p::predator::do_next_if)<> (UNSET) called - dispatching to ::p::${if_sub}::_iface::$method with args:'$args'" - return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] - - } elseif {$method in [dict keys [set ::p::${if_sub}::_iface::o_methods]]} { - if {[llength $args]} { - #puts stdout "<>(::p::predator::do_next_if)<> - - - calling ::p::${if_sub}::_iface::$method on sub interface $if_sub with $args" - - #return [::p::${if_sub}::_iface::$method $_ID_ {*}$args] - #tailcall ::p::${if_sub}::_iface::$method $_ID_ {*}$args - - #!todo - handle case where llength $args is less than number of args for subinterface command - #i.e remaining args will need to be upvared to get values from calling scope (auto-set any values not explicitly set) - - #handle case where next interface has different arguments (masking of sub interfaces in the stack with function with different arity/signature) - set head [interp alias {} ::p::${if_sub}::_iface::$method] - set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc - set argx [list] - foreach a $nextArgs { - lappend argx "\$a" - } - - #todo - handle func a b args called with func "x" ie short on named vars so b needs to be upvared - - if {([llength $args] == [llength $nextArgs]) || ([lindex $nextArgs end] eq "args")} { - tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args - } else { - #todo - upvars required for tail end of arglist - tailcall apply [list $nextArgs [list ::p::${if_sub}::_iface::$method {*}$argx ]] $_ID_ {*}$args - } - - } else { - #auto-set: upvar vars from calling scope - #!todo - robustify? alias not necessarily matching command name.. - set head [interp alias {} ::p::${if_sub}::_iface::$method] - - - set nextArgs [info args $head] ;#!todo - fix... head not necessarily a proc - if {[llength $nextArgs] > 1} { - set argVals [::list] - set i 0 - foreach arg [lrange $nextArgs 1 end] { - upvar 1 $arg $i - if {$arg eq "args"} { - #need to check if 'args' is actually available in caller - if {[info exists $i]} { - set argVals [concat $argVals [set $i]] - } - } else { - lappend argVals [set $i] - } - } - #return [$head $_ID_ {*}$argVals] - tailcall $head $_ID_ {*}$argVals - } else { - #return [$head $_ID_] - tailcall $head $_ID_ - } - } - } elseif {$method eq "(CONSTRUCTOR)"} { - #chained constructors will only get args if the @next@ caller explicitly provided them. - puts stdout "!!!<>(::p::predator::do_next_if)<> CONSTRUCTOR CHAINED CALL via do_next_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" - #return [::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args] - xtailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args - } - } - #no interfaces in the iStack contained a matching method. - return - } else { - #no further interfaces in this iStack - return - } -} - - -#only really makes sense for (CONSTRUCTOR) calls. -#_ID_ is the invocant data for the target. caller_ID_ is the invocant data for the calling(creating,cloning etc) pattern/class. -proc ::p::predator::do_next_pattern_if {_ID_ caller_ID_ IFID method args} { - #puts ")))) do_next_pattern_if _ID_:'$_ID_' IFID:'$IFID' method:'$method' args:'$args' (((" - - #set invocants [dict get $_ID_ i] - #set this_invocant [lindex [dict get $invocants this] 0] - #lassign $this_invocant OID this_info - #set OID [lindex [dict get $invocants this] 0 0] - #upvar #0 ::p::${OID}::_meta::map map - #lassign [lindex $map 0] OID alias itemCmd cmd - - - set caller_OID [lindex [dict get $caller_ID_ i this] 0 0] - upvar #0 ::p::${caller_OID}::_meta::map callermap - - #set interfaces [lindex $map 1 0] - set patterninterfaces [dict get $callermap interfaces level1] - - set L0_posn [lsearch $patterninterfaces $IFID] - if {$L0_posn == -1} { - error "do_next_pattern_if called with interface not present at level1 for this object" - } elseif {$L0_posn > 0} { - - - set lower_interfaces [lrange $patterninterfaces 0 $L0_posn-1] - - foreach if_sub [lreverse $lower_interfaces] { - if {$method eq "(CONSTRUCTOR)"} { - #chained constructors will only get args if the @next@ caller explicitly provided them. - #puts stdout "!!! CONSTRUCTOR CHAINED CALL via do_next_pattern_if _ID_:$_ID_ IFID:$IFID method:$method args:$args!!!" - tailcall ::p::${if_sub}::_iface::(CONSTRUCTOR) $_ID_ {*}$args - } - } - #no interfaces in the iStack contained a matching method. - return - } else { - #no further interfaces in this iStack - return - } -} - - - - - -#------------------------------------------------------------------------------------------------ - - - - - -#------------------------------------------------------------------------------------- -####################################################### -####################################################### -####################################################### -####################################################### -####################################################### -####################################################### -####################################################### - - -#!todo - can we just call new_object somehow to create this? - - #until we have a version of Tcl that doesn't have 'creative writing' scope issues - - # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword. - # (see http://mini.net/tcl/1030 'Dangers of creative writing') -namespace eval ::p::-1 { - #namespace ensemble create - - namespace eval _ref {} - namespace eval _meta {} - - namespace eval _iface { - variable o_usedby - variable o_open - variable o_constructor - variable o_variables - variable o_properties - variable o_methods - variable o_definition - variable o_varspace - variable o_varspaces - - array set o_usedby [list i0 1] ;#!todo - review - #'usedby' array the metaface is an exception. All objects use it - so we should list none of them rather than pointless updating of this value? - - set o_open 1 - set o_constructor [list] - set o_variables [list] - set o_properties [dict create] - set o_methods [dict create] - array set o_definition [list] - set o_varspace "" - set o_varspaces [list] - } -} - - -# - -#interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list [list -1 ::p::internals::>metaface item {}] {{} {}}] -interp alias {} ::p::internals::>metaface {} ::p::internals::predator [list i [list this [list [list -1 ::p::internals::>metaface item {}]]] context {}] - - -upvar #0 ::p::-1::_iface::o_definition def - - -#! concatenate -> compose ?? -dict set ::p::-1::_iface::o_methods Concatenate {arglist {target args}} -proc ::p::-1::Concatenate {_ID_ target args} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - if {![string match "::*" $target]} { - if {[set ns [uplevel 1 {namespace current}]] eq "::"} { - set target ::$target - } else { - set target ${ns}::$target - } - } - #add > character if not already present - set target [namespace qualifiers $target]::>[string trimleft [namespace tail $target] >] - set _target [string map {::> ::} $target] - - set ns [namespace qualifiers $target] - if {$ns eq ""} { - set ns "::" - } else { - namespace eval $ns {} - } - - if {![llength [info commands $target]]} { - #degenerate case - target does not exist - #Probably just 1st of a set of Concatenate calls - so simply delegate to 'Clone' - #review - should be 'Copy' so it has object state from namespaces and variables? - return [::p::-1::Clone $_ID_ $target {*}$args] - - #set TARGETMAP [::p::predator::new_object $target] - #lassign [lindex $TARGETMAP 0] target_ID target_cmd itemCmd - - } else { - #set TARGETMAP [lindex [interp alias {} [namespace origin $target]] 1] - set TARGETMAP [$target --] - - lassign [dict get $TARGETMAP invocantdata] target_ID target_cmd itemCmd - - #Merge lastmodified(?) level0 and level1 interfaces. - - } - - return $target -} - - - -#Object's Base-Interface proc with itself as curried invocant. -#interp alias {} ::p::-1::Create {} ::p::-1::_iface::Create $invocant -#namespace eval ::p::-1 {namespace export Create} -dict set ::p::-1::_iface::o_methods Define {arglist definitions} -#define objects in one step -proc ::p::-1::Define {_ID_ definitions} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - lassign [dict get $MAP invocantdata] OID alias default_method cmd - set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces - set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces - - #!todo - change these to dicts; key=interface stack name value= a list of interfaces in the stack - #set IFID0 [lindex $interfaces 0] - #set IFID1 [lindex $patterns 0] ;#1st pattern - - #set IFID_TOP [lindex $interfaces end] - set IFID_TOP [::p::predator::get_possibly_new_open_interface $OID] - - #set ns ::p::${OID} - - #set script [string map [list %definitions% $definitions] { - # if {[lindex [namespace path] 0] ne "::p::-1"} { - # namespace path [list ::p::-1 {*}[namespace path]] - # } - # %definitions% - # namespace path [lrange [namespace path] 1 end] - # - #}] - - set script [string map [list %id% $_ID_ %definitions% $definitions] { - set ::p::-1::temp_unknown [namespace unknown] - - namespace unknown [list ::apply {{funcname args} {::p::predator::redirect $funcname [list %id%] {*}$args}}] - - - #namespace unknown [list ::apply { {funcname args} {if {![llength [info commands ::p::-1::$funcname]]} {::unknown $funcname {*}$args } else {::p::-1::$funcname [list %id%] {*}$args} }} ] - - - %definitions% - - - namespace unknown ${::p::-1::temp_unknown} - return - }] - - - - #uplevel 1 $script ;#this would run the script in the global namespace - #run script in the namespace of the open interface, this allows creating of private helper procs - #namespace inscope ::p::${IFID_TOP}::_iface $script ;#do not use tailcall here! Define belongs on the callstack - #namespace inscope ::p::${OID} $script - namespace eval ::p::${OID} $script - #return $cmd -} - - -proc ::p::predator::redirect {func args} { - - #todo - review tailcall - tests? - if {![llength [info commands ::p::-1::$func]]} { - #error "invalid command name \"$func\"" - tailcall uplevel 1 [list ::unknown $func {*}$args] - } else { - tailcall uplevel 1 [list ::p::-1::$func {*}$args] - } -} - - -#'immediate' constructor - this is really like a (VIOLATE) call.. todo - review. -dict set ::p::-1::_iface::o_methods Construct {arglist {argpairs body args}} -proc ::p::-1::Construct {_ID_ argpairs body args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set interfaces [dict get $MAP interfaces level0] - set iid_top [lindex $interfaces end] - namespace upvar ::p::${iid_top}::_iface o_varspaces o_varspaces o_varspace o_varspace - - set ARGSETTER {} - foreach {argname argval} $argpairs { - append ARGSETTER "set $argname $argval\n" - } - #$_self (VIOLATE) $ARGSETTER$body - - set body $ARGSETTER\n$body - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls\n[dict get $processed body] - # puts stderr "\t runtime_vardecls in Construct $varDecls" - } - - set next "\[error {next not implemented}\]" - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]"] $body\n] - 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] - - - #namespace eval ::p::${iid_top} $body - - #return [apply [list {_ID_ args} $body ::p::${iid_top}::_iface] $_ID_] - #does this handle Varspace before constructor? - return [apply [list {_ID_ args} $body ::p::${OID} ] $_ID_ {*}$args] -} - - - - - -#hacked optimized version of ::p::-1::Create for creating ::p::ifaces::>* objects -namespace eval ::p::3 {} -proc ::p::3::_create {child {OID "-2"}} { - #puts stderr "::p::3::_create $child $OID" - set _child [string map {::> ::} $child] - if {$OID eq "-2"} { - #set childmapdata [::p::internals::new_object $child] - #set child_ID [lindex [dict get $childmapdata invocantdata] 0 ] - set child_ID [lindex [dict get [::p::internals::new_object $child] invocantdata] 0] - upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - } else { - set child_ID $OID - #set _childmap [::p::internals::new_object $child "" $child_ID] - ::p::internals::new_object $child "" $child_ID - upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - } - - #-------------- - - set oldinterfaces [dict get $CHILDMAP interfaces] - dict set oldinterfaces level0 [list 2] - set modifiedinterfaces $oldinterfaces - dict set CHILDMAP interfaces $modifiedinterfaces - - #-------------- - - - - - #puts stderr ">>>> creating alias for ::p::$child_ID" - #puts stderr ">>>::p::3::_create $child $OID >>>[interp alias {} ::p::$child_ID]" - - #interp alias ::p::$child_ID already exists at this point - so calling here will do nothing! - #interp alias {} ::p::$child_ID {} ::p::internals::predator [dict create i [dict create this [list [list $child_ID {} ]]]] - #puts stderr ">>>[interp alias {} ::p::$child_ID]" - - - - #--------------- - namespace upvar ::p::2::_iface o_methods o_methods o_properties o_properties - foreach method [dict keys $o_methods] { - #todo - change from interp alias to context proc - interp alias {} ::p::${child_ID}::$method {} ::p::2::_iface::$method - } - #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] - #implement property even if interface already compiled because we need to create defaults for each new child obj. - # also need to add alias on base interface - #make sure we are only implementing properties from the current CREATOR - dict for {prop pdef} $o_properties { - #lassign $pdef prop default - interp alias {} ::p::${child_ID}::$prop {} ::p::2::_iface::(GET)$prop - interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::2::_iface::(GET)$prop - - } - ::p::2::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata]]] context {}] - #--------------- - #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" - return $child -} - -#configure -prop1 val1 -prop2 val2 ... -dict set ::p::-1::_iface::o_methods Configure {arglist args} -proc ::p::-1::Configure {_ID_ args} { - - #!todo - add tests. - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - lassign [dict get $MAP invocantdata] OID alias itemCmd this - - if {![expr {([llength $args] % 2) == 0}]} { - error "expected even number of Configure args e.g '-property1 value1 -property2 value2'" - } - - #Do a separate loop to check all the arguments before we run the property setting loop - set properties_to_configure [list] - foreach {argprop val} $args { - if {!([string range $argprop 0 0] eq "-") || ([string length $argprop] < 2)} { - error "expected Configure args in the form: '-property1 value1 -property2 value2'" - } - lappend properties_to_configure [string range $argprop 1 end] - } - - #gather all valid property names for all level0 interfaces in the relevant interface stack - set valid_property_names [list] - set iflist [dict get $MAP interfaces level0] - foreach id [lreverse $iflist] { - set interface_property_names [dict keys [set ::p::${id}::_iface::o_properties]] - foreach if_prop $interface_property_names { - if {$if_prop ni $valid_property_names} { - lappend valid_property_names $if_prop - } - } - } - - foreach argprop $properties_to_configure { - if {$argprop ni $valid_property_names} { - error "Configure failed - no changes made. Unable to find property '$argprop' on object $this OID:'$OID' valid properties: $valid_property_names" - } - } - - set top_IID [lindex $iflist end] - #args ok - go ahead and set all properties - foreach {prop val} $args { - set property [string range $prop 1 end] - #------------ - #don't use property ref unnecessarily - leaves property refs hanging around which traces need to update - #ie don't do this here: set [$this . $property .] $val - #------------- - ::p::${top_IID}::_iface::(SET)$property $_ID_ $val ;#equivalent to [$this . (SET)$property $val] - } - return -} - - - - - - -dict set ::p::-1::_iface::o_methods AddPatternInterface {arglist iid} -proc ::p::-1::AddPatternInterface {_ID_ iid} { - #puts stderr "!!!!!!!!!!!!!!! ::p::-1::AddPatternInterface $_ID_ $iid" - if {![string is integer -strict $iid]} { - error "adding interface by name not yet supported. Please use integer id" - } - - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - #lassign [lindex $invocant 0] OID alias itemCmd cmd - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set existing_ifaces [dict get $MAP interfaces level1] ;#pattern interfaces - - - - #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? - - lappend existing_ifaces $iid - #lset map {1 1} $existing_ifaces - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 $existing_ifaces - dict set MAP interfaces $extracted_sub_dict - - #lset invocant {1 1} $existing_ifaces - -} - - -#!todo - update usedby ?? -dict set ::p::-1::_iface::o_methods AddInterface {arglist iid} -proc ::p::-1::AddInterface {_ID_ iid} { - #puts stderr "::p::-1::AddInterface _ID_:$_ID_ iid:$iid" - if {![string is integer -strict $iid]} { - error "adding interface by name not yet supported. Please use integer id" - } - - - 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 - - upvar #0 ::p::${OID}::_meta::map MAP - set existing_ifaces [dict get $MAP interfaces level0] - - lappend existing_ifaces $iid - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 $existing_ifaces - dict set MAP interfaces $extracted_sub_dict - return [dict get $extracted_sub_dict level0] -} - - - -# The 'Create' method on the meta-interface has 2 variants (CreateNew & CreateOverlay) provided to enhance code clarity for the application using the pattern module. -# The 'Create' method could be used in all instances - but 'CreateNew' is designed for the case where the target/child object does not yet exist -# and 'CreateOverlay' for the case where the target/child object already exists. -# If the application writer follows the convention of using 'CreateNew' & 'CreateOverlay' instead of 'Create' - it should be more obvious where a particular object first comes into existence, -# and it should reduce errors where the author was expecting to overlay an existing object, but accidentally created a new object. -# 'CreateNew' will raise an error if the target already exists -# 'CreateOverlay' will raise an error if the target object does not exist. -# 'Create' will work in either case. Creating the target if necessary. - - -#simple form: -# >somepattern .. Create >child -#simple form with arguments to the constructor: -# >somepattern .. Create >child arg1 arg2 etc -#complex form - specify more info about the target (dict keyed on childobject name): -# >somepattern .. Create {>child {-id 1}} -#or -# >somepattern .. Create [list >child {-id 1 -somethingelse etc} >child2 {}] -#complex form - with arguments to the contructor: -# >somepattern .. Create [list >child {-id 1}] arg1 arg2 etc -dict set ::p::-1::_iface::o_methods Create {arglist {target_spec args}} -proc ::p::-1::Create {_ID_ target_spec args} { - #$args are passed to constructor - if {[llength $target_spec] ==1} { - set child $target_spec - set targets [list $child {}] - } else { - set targets $target_spec - } - - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - set invocants [dict get $_ID_ i] - set invocant_roles [dict keys $invocants] ;#usually the only invocant role present will be 'this' (single dispatch case) - - foreach {child target_spec_dict} $targets { - #puts ">>>::p::-1::Create $_ID_ $child $args <<<" - - - - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - - - - - #puts ">>Create _ID_:$_ID_ child:$child args:$args map:$map OID:$OID" - - #child should already be fully ns qualified (?) - #ensure it is has a pattern-object marker > - #puts stderr ".... $child (nsqual: [namespace qualifiers $child])" - - - lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd - set interfaces [dict get $MAP interfaces level0] ;#level-0 interfaces - set patterns [dict get $MAP interfaces level1] ;#level-1 interfaces - #puts "parent: $OID -> child:$child Patterns $patterns" - - #todo - change to dict of interface stacks - set IFID0 [lindex $interfaces 0] - set IFID1 [lindex $patterns 0] ;#1st pattern - - #upvar ::p::${OID}:: INFO - - 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] >] - set _child [string map {::> ::} $child] - - set ns [namespace qualifiers $child] - if {$ns eq ""} { - set ns "::" - } else { - namespace eval $ns {} - } - - - #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 $cmd when creating $child" - #lappend patterns [::p::internals::new_interface $OID] - - #lset invocant {1 1} $patterns - ##update our command because we changed the interface list. - #set IFID1 [lindex $patterns 0] - - #set patterns [list [::p::internals::new_interface $OID]] - - #set patterns [list [::p::internals::new_interface]] - - #set patterns [list [set iid [expr {$::p::ID + 1}]]] ;#PREDICT the next object's id - #set patterns [list [set iid [incr ::p::ID]]] - set patterns [list [set iid [::p::get_new_object_id]]] - - #--------- - #set iface [::p::>interface .. Create ::p::ifaces::>$iid] - #::p::-1::Create [list {caller ::p::3}] ::p::ifaces::>$iid - - #lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid] ;#interface creation - lappend new_interfaces [::p::3::_create ::p::ifaces::>$iid $iid] - - #--------- - - #puts "??> p::>interface .. Create ::p::ifaces::>$iid" - #puts "??> [::p::ifaces::>$iid --]" - #set [$iface . UsedBy .] - } - set parent_patterndefaultmethod [dict get $MAP patterndata patterndefaultmethod] - - #if {![llength [info commands $child]]} {} - - if {[namespace which $child] eq ""} { - #normal case - target/child does not exist - set is_new_object 1 - - if {[dict exists $target_spec_dict -id]} { - set childmapdata [::p::internals::new_object $child "" [dict get $target_spec_dict -id]] - } else { - set childmapdata [::p::internals::new_object $child] - } - lassign [dict get $childmapdata invocantdata] child_ID child_alias child_defaultmethod - upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - - - - #child initially uses parent's level1 interface as it's level0 interface - # child has no level1 interface until PatternMethods or PatternProperties are added - # (or applied via clone; or via create with a parent with level2 interface) - #set child_IFID $IFID1 - - #lset CHILDMAP {1 0} [list $IFID1] - #lset CHILDMAP {1 0} $patterns - - set extracted_sub_dict [dict get $CHILDMAP interfaces] - dict set extracted_sub_dict level0 $patterns - dict set CHILDMAP interfaces $extracted_sub_dict - - #why write back when upvared??? - #review - set ::p::${child_ID}::_meta::map $CHILDMAP - - #::p::predator::remap $CHILDMAP - - #interp alias {} $child {} ::p::internals::predator $CHILDMAP - - #set child_IFID $IFID1 - - #upvar ::p::${child_ID}:: child_INFO - - #!todo review - #set n ::p::${child_ID} - #if {![info exists ${n}::-->PATTERN_ANCHOR]} { - # #puts stdout "### target:'$child' Creating ${n}::-->PATTERN_ANCHOR (unset trace to delete namespace '$n'" - # #!todo - keep an eye on tip.tcl.tk #140 - 'Tracing Namespace Modification' - may be able to do away with this hack - # set ${n}::-->PATTERN_ANCHOR "objects within this namespace will be deleted when this var is unset" - # trace add variable ${n}::-->PATTERN_ANCHOR {unset} [list ::p::meta::clear_ns $n] - #} - - set ifaces_added $patterns - - } else { - #overlay/mixin case - target/child already exists - set is_new_object 0 - - #set CHILDMAP [lindex [interp alias {} [namespace origin $child]] 1] - set childmapdata [$child --] - - - #puts stderr " *** $cmd .. Create -> target $child already exists!!!" - #puts " **** CHILDMAP: $CHILDMAP" - #puts " ****" - - #puts stderr " ---> Properties: [$child .. Properties . names]" - #puts stderr " ---> Methods: [$child .. Properties . names]" - - lassign [dict get $childmapdata invocantdata] child_ID child_alias child_default child_cmd - upvar #0 ::p::${child_ID}::_meta::map CHILDMAP - - #set child_IFID [lindex $CHILDMAP 1 0 end] - #if {$child_IFID != [set child_IFID [::p::internals::expand_interface $child_IFID]]} { - # lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $child_IFID] - # interp alias {} $child_cmd {} ::p::internals::predator $CHILDMAP - #} - ##!todo? - merge only 'open' parent interfaces onto 'open' target interfaces - #::p::merge_interface $IFID1 $child_IFID - - - set existing_interfaces [dict get $CHILDMAP interfaces level0] - set ifaces_added [list] - foreach p $patterns { - if {$p ni $existing_interfaces} { - lappend ifaces_added $p - } - } - - if {[llength $ifaces_added]} { - #lset CHILDMAP {1 0} [concat [lindex $CHILDMAP 1 0] $ifaces_added] - set extracted_sub_dict [dict get $CHILDMAP interfaces] - dict set extracted_sub_dict level0 [concat $existing_interfaces $ifaces_added] - dict set CHILDMAP interfaces $extracted_sub_dict - #set ::p::${child_ID}::_meta::map $CHILDMAP ;#why? - #::p::predator::remap $CHILDMAP - } - } - - #do not overwrite the child's defaultmethod value if the parent_patterndefaultmethod is empty - if {$parent_patterndefaultmethod ne ""} { - set child_defaultmethod $parent_patterndefaultmethod - set CHILD_INVOCANTDATA [dict get $CHILDMAP invocantdata] - lset CHILD_INVOCANTDATA 2 $child_defaultmethod - dict set CHILDMAP invocantdata $CHILD_INVOCANTDATA - #update the child's _ID_ - interp alias {} $child_alias {} ;#first we must delete it - interp alias {} $child_alias {} ::p::internals::predator [list i [list this [list $CHILD_INVOCANTDATA] ] context {}] - - #! object_command was initially created as the renamed alias - so we have to do it again - rename $child_alias $child - trace add command $child rename [list $child .. Rename] - } - #!todo - review - dont we already have interp alias entries for every method/prop? - #namespace eval ::p::${child_ID} "namespace ensemble create -command $_child" - - - - - - set constructor_failure 0 ;#flag to indicate abortion due to error during a constructor call. - - - - #------------------------------------------------------------------------------------ - #create snapshot of the object-namespaces variables to allow object state to be rolledback if any Constructor calls fail. - # - All variables under the namespace - not just those declared as Variables or Properties - # - use a namespace. For the usual case of success, we just namespace delete, and remove the COW traces. - # - presumably this snapshot should be reasonably efficient even if variables hold large amounts of data, as Tcl implements Copy-On-Write. - - #NOTE - do not use the objectID as the sole identifier for the snapshot namespace. - # - there may be multiple active snapshots for a single object if it overlays itself during a constructor, - # and it may be that a failure of an inner overlay is deliberately caught and not considered reason to raise an error for the initial constructor call. - # - we will use an ever-increasing snapshotid to form part of ns_snap - set ns_snap "::p::snap::[incr ::p::snap::id]_$child_ID" ;#unique snapshot namespace for this call to Create. - - #!todo - this should look at child namespaces (recursively?) - #!todo - this should examine any namespaces implied by the default 'varspace' value for all interfaces. - # (some of these namespaces might not be descendants of the object's ::p::${child_ID} namespace) - - namespace eval $ns_snap {} - foreach vname [info vars ::p::${child_ID}::*] { - set shortname [namespace tail $vname] - if {[array exists $vname]} { - array set ${ns_snap}::${shortname} [array get $vname] - } elseif {[info exists $vname]} { - set ${ns_snap}::${shortname} [set $vname] - } else { - #variable exists without value (e.g created by 'variable' command) - namespace eval $ns_snap [list variable $shortname] ;#create the variable without value, such that it is present, but does not 'info exist' - } - } - #------------------------------------------------------------------------------------ - - - - - - - - - - #puts "====>>> ifaces_added $ifaces_added" - set idx 0 - set idx_count [llength $ifaces_added] - set highest_constructor_IFID "" - foreach IFID $ifaces_added { - incr idx - #puts "--> adding iface $IFID " - namespace upvar ::p::${IFID}::_iface o_usedby o_usedby o_open o_open o_methods o_methods o_properties o_properties o_variables o_variables o_unknown o_unknown o_varspace o_varspace o_varspaces o_varspaces - - if {[llength $o_varspaces]} { - foreach vs $o_varspaces { - #ensure all varspaces for the interface exists so that the 'namespace upvar' entries in methods etc will work. - if {[string match "::*" $vs]} { - namespace eval $vs {} ;#an absolute path to a namespace which may not be under the object's namespace at all. - } else { - namespace eval ::p::${child_ID}::$vs {} - } - } - } - - if {$IFID != 2} { - #>ifinfo interface always has id 2 and is used by all interfaces - no need to add everything to its usedby list. - if {![info exists o_usedby(i$child_ID)]} { - set o_usedby(i$child_ID) $child_alias - } - - #compile and close the interface only if it is shared - if {$o_open} { - ::p::predator::compile_interface $IFID $_ID_ ;#params: IFID , caller_ID_ - set o_open 0 - } - } - - - - package require struct::set - - set propcmds [list] - foreach cmd [info commands ::p::${IFID}::_iface::(GET)*] { - set cmd [namespace tail $cmd] - #may contain multiple results for same prop e.g (GET)x.3 - set cmd [string trimright $cmd 0123456789] - set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals - lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. - } - set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. - #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. - foreach property $propcmds { - #puts "\n\n ::p::${child_ID}::$property --->>>>>>>>>>>> ::p::${IFID}::_iface::(GET)$property \n" - interp alias {} ::p::${child_ID}::(GET)$property {} ::p::${IFID}::_iface::(GET)$property ;#used by property reference traces - interp alias {} ::p::${child_ID}::$property {} ::p::${IFID}::_iface::(GET)$property - } - - set propcmds [list] - foreach cmd [info commands ::p::${IFID}::_iface::(SET)*] { - set cmd [namespace tail $cmd] - #may contain multiple results for same prop e.g (GET)x.3 - set cmd [string trimright $cmd 0123456789] - set cmd [string trimright $cmd .] ;#do separately in case cmd name also contains numerals - lappend propcmds [string range $cmd 5 end] ;#don't worry about dupes here. - } - set propcmds [struct::set union $propcmds] ;#a way to get rid of dupes. - #$propcmds now holds all Properties as well as PropertyReads with no corresponding Property on this interface. - foreach property $propcmds { - interp alias {} ::p::${child_ID}::(SET)$property {} ::p::${IFID}::_iface::(SET)$property ;#used by property reference traces - } - - - foreach method [dict keys $o_methods] { - set arglist [dict get $o_methods $method arglist] - set argvals "" - foreach argspec $arglist { - if {[llength $argspec] == 2} { - set a [lindex $argspec 0] - } else { - set a $argspec - } - - if {$a eq "args"} { - append argvals " \{*\}\$args" - } else { - append argvals " \$$a" - } - } - set argvals [string trimleft $argvals] - - #interp alias {} ::p::${child_ID}::$method {} ::p::${IFID}::_iface::$method - - #this proc directly on the object is not *just* a forwarding proc - # - it provides a context in which the 'uplevel 1' from the running interface proc runs - #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) - - #proc calls the method in the interface - which is an interp alias to the head of the implementation chain - - - proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [subst { - ::p::${IFID}::_iface::$method \$_ID_ $argvals - }] - - #proc ::p::${child_ID}::$method [list _ID_ {*}$arglist] [string map [list @m@ $method @ID@ $IFID @argvals@ $argvals] { - # ::p::@ID@::_iface::@m@ $_ID_ @argvals@ - #}] - - - } - - #namespace eval ::p::${child_ID} [list namespace export {*}$o_methods] - - #implement property even if interface already compiled because we need to create defaults for each new child obj. - # also need to add alias on base interface - #make sure we are only implementing properties from the current CREATOR - dict for {prop pdef} $o_properties { - set varspace [dict get $pdef varspace] - if {![string length $varspace]} { - set ns ::p::${child_ID} - } else { - if {[string match "::*" $varspace]} { - set ns $varspace - } else { - set ns ::p::${child_ID}::$varspace - } - } - if {[dict exists $pdef default]} { - if {![info exists ${ns}::o_$prop]} { - #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) - set ${ns}::o_$prop [dict get $pdef default] - } - } - #! May be replaced by a method with the same name - if {$prop ni [dict keys $o_methods]} { - interp alias {} ::p::${child_ID}::$prop {} ::p::${IFID}::_iface::(GET)$prop - } - interp alias {} ::p::${child_ID}::(GET)$prop {} ::p::${IFID}::_iface::(GET)$prop - interp alias {} ::p::${child_ID}::(SET)$prop {} ::p::${IFID}::_iface::(SET)$prop - } - - - - #variables - #foreach vdef $o_variables { - # if {[llength $vdef] == 2} { - # #there is a default value defined. - # lassign $vdef v default - # if {![info exists ::p::${child_ID}::$v]} { - # set ::p::${child_ID}::$v $default - # } - # } - #} - dict for {vname vdef} $o_variables { - if {[dict exists $vdef default]} { - #there is a default value defined. - set varspace [dict get $vdef varspace] - if {$varspace eq ""} { - set ns ::p::${child_ID} - } else { - if {[string match "::*" $varspace]} { - set ns $varspace - } else { - set ns ::p::${child_ID}::$varspace - } - } - set ${ns}::$vname [dict get $vdef default] - } - } - - - #!todo - review. Write tests for cases of multiple constructors! - - #We don't want to the run constructor for each added interface with the same set of args! - #run for last one - rely on constructor authors to use @next@ properly? - if {[llength [set ::p::${IFID}::_iface::o_constructor]]} { - set highest_constructor_IFID $IFID - } - - if {$idx == $idx_count} { - #we are processing the last interface that was added - now run the latest constructor found - if {$highest_constructor_IFID ne ""} { - #at least one interface has a constructor - if {[llength [set ::p::${highest_constructor_IFID}::_iface::o_constructor]]} { - #puts ">>!! running constructor ifid:$highest_constructor_IFID child: $CHILDMAP" - if {[catch {::p::${highest_constructor_IFID}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CHILDMAP invocantdata] ] ]] {*}$args} constructor_error]} { - set constructor_failure 1 - set constructor_errorInfo $::errorInfo ;#cache it immediately. - break - } - } - } - } - - if {[info exists o_unknown]} { - interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${IFID}::_iface::$o_unknown - interp alias {} ::p::${child_ID}::(UNKNOWN) {} ::p::${child_ID}::$o_unknown - - - #interp alias {} ::p::${IFID}::_iface::(UNKNOWN) {} ::p::${child_ID}::$o_unknown - #namespace eval ::p::${IFID}::_iface [list namespace unknown $o_unknown] - #namespace eval ::p::${child_ID} [list namespace unknown $o_unknown] - } - } - - if {$constructor_failure} { - if {$is_new_object} { - #is Destroy enough to ensure that no new interfaces or objects were left dangling? - $child .. Destroy - } else { - #object needs to be returned to a sensible state.. - #attempt to rollback all interface additions and object state changes! - puts "!!!!!!!!!!!!!!!!>>>constructor rollback object $child_ID \n\n\n\n" - #remove variables from the object's namespace - which don't exist in the snapshot. - set snap_vars [info vars ${ns_snap}::*] - puts "ns_snap '$ns_snap' vars'${snap_vars}'" - foreach vname [info vars ::p::${child_ID}::*] { - set shortname [namespace tail $vname] - if {"${ns_snap}::$shortname" ni "$snap_vars"} { - #puts "--- >>>>> unsetting $shortname " - unset -nocomplain $vname - } - } - - #restore variables from snapshot - but try to do so with minimal writes (don't want to trigger any unnecessary traces) - #values of vars may also have Changed - #todo - consider traces? what is the correct behaviour? - # - some application traces may have fired before the constructor error occurred. - # Should the rollback now also trigger traces? - #probably yes. - - #we need to test both source and dest var for arrayness - as the failed constructor could have changed the variable type, not just the value - foreach vname $snap_vars { - #puts stdout "@@@@@@@@@@@ restoring $vname" - #flush stdout - - - set shortname [namespace tail $vname] - set target ::p::${child_ID}::$shortname - if {$target in [info vars ::p::${child_ID}::*]} { - set present 1 ;#variable exists in one of 3 forms; array, simple, or 'declared only' - } else { - set present 0 - } - - if {[array exists $vname]} { - #restore 'array' variable - if {!$present} { - array set $target [array get $vname] - } else { - if {[array exists $target]} { - #unset superfluous elements - foreach key [array names $target] { - if {$key ni [array names $vname]} { - array unset $target $key - } - } - #.. and write only elements that have changed. - foreach key [array names $vname] { - if {[set ${target}($key)] ne [set ${vname}($key)]} { - set ${target}($key) [set ${vname}($key)] - } - } - } else { - #target has been changed to a simple variable - unset it and recreate the array. - unset $target - array set $target [array get $vname] - } - } - } elseif {[info exists $vname]} { - #restore 'simple' variable - if {!$present} { - set $target [set $vname] - } else { - if {[array exists $target]} { - #target has been changed to array - unset it and recreate the simple variable. - unset $target - set $target [set $vname] - } else { - if {[set $target] ne [set $vname]} { - set $target [set $vname] - } - } - } - } else { - #restore 'declared' variable - if {[array exists $target] || [info exists $target]} { - unset -nocomplain $target - } - namespace eval ::p::${child_ID} [list variable $shortname] - } - } - } - namespace delete $ns_snap - return -code error -errorinfo "oid:${child_ID} constructor_failure for IFID:${IFID}\n$constructor_errorInfo" $constructor_error - } - namespace delete $ns_snap - - } - - - - return $child -} - -dict set ::p::-1::_iface::o_methods Clone {arglist {clone args}} -#A cloned individual doesn't have the scars of its parent. i.e values (state) not *copied* -# (new 'clean' object with same structure. values as set by constructor or *specified by defaults*) -# Also: Any 'open' interfaces on the parent become closed on clone! -proc ::p::-1::Clone {_ID_ clone args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set invocants [dict get $_ID_ i] - lassign [dict get $MAP invocantdata] OID alias parent_defaultmethod cmd - - set _cmd [string map {::> ::} $cmd] - set tail [namespace tail $_cmd] - - - #obsolete? - ##set IFID0 [lindex $map 1 0 end] - #set IFID0 [lindex [dict get $MAP interfaces level0] end] - ##set IFID1 [lindex $map 1 1 end] - #set IFID1 [lindex [dict get $MAP interfaces level1] end] - - - if {![string match "::*" $clone]} { - if {[set ns [uplevel 1 {namespace current}]] eq "::"} { - set clone ::$clone - } else { - set clone ${ns}::$clone - } - } - - - set clone [namespace qualifiers $clone]::>[string trimleft [namespace tail $clone] >] - set _clone [string map {::> ::} $clone] - - - set cTail [namespace tail $_clone] - - set ns [namespace qualifiers $clone] - if {$ns eq ""} { - set ns "::" - } - - namespace eval $ns {} - - - #if {![llength [info commands $clone]]} {} - if {[namespace which $clone] eq ""} { - set clonemapdata [::p::internals::new_object $clone] - } else { - #overlay/mixin case - target/clone already exists - #set CLONEMAP [lindex [interp alias {} [namespace origin $clone]] 1] - set clonemapdata [$clone --] - } - set clone_ID [lindex [dict get $clonemapdata invocantdata] 0] - - upvar #0 ::p::${clone_ID}::_meta::map CLONEMAP - - - #copy patterndata element of MAP straight across - dict set CLONEMAP patterndata [dict get $MAP patterndata] - set CLONE_INVOCANTDATA [dict get $CLONEMAP invocantdata] - lset CLONE_INVOCANTDATA 2 $parent_defaultmethod - dict set CLONEMAP invocantdata $CLONE_INVOCANTDATA - lassign $CLONE_INVOCANTDATA clone_ID clone_alias clone_defaultmethod clone - - #update the clone's _ID_ - interp alias {} $clone_alias {} ;#first we must delete it - interp alias {} $clone_alias {} ::p::internals::predator [list i [list this [list $CLONE_INVOCANTDATA] ] context {}] - - #! object_command was initially created as the renamed alias - so we have to do it again - rename $clone_alias $clone - trace add command $clone rename [list $clone .. Rename] - - - - - #obsolete? - #upvar ::p::${clone_ID}:: clone_INFO - #upvar ::p::${IFID0}:: IFACE ;#same interface on predecessor(self) and clone. - #upvar ::p::${OID}:: INFO - - - array set clone_INFO [array get INFO] - - array set ::p::${clone_ID}::_iface::o_usedby [list] ;#'usedby' - - - #!review! - #if {![catch {set itemCmd $IFACE(m-1,name,item)}]} { - #puts "***************" - #puts "clone" - #parray IFINFO - #puts "***************" - #} - - #we need the parent(s) in order to 'clone'??? - probably, as the defs are usually there unless the object was created with ad-hoc methods/props directly from ::>pattern - - - #clone's interface maps must be a superset of original's - foreach lev {0 1} { - #set parent_ifaces [lindex $map 1 $lev] - set parent_ifaces [dict get $MAP interfaces level$lev] - - #set existing_ifaces [lindex $CLONEMAP 1 $lev] - set existing_ifaces [dict get $CLONEMAP interfaces level$lev] - - set added_ifaces_$lev [list] - foreach ifid $parent_ifaces { - if {$ifid ni $existing_ifaces} { - - #interface must not remain extensible after cloning. - if {[set ::p::${ifid}::_iface::o_open]} { - ::p::predator::compile_interface $ifid $_ID_ - set ::p::${ifid}::_iface::o_open 0 - } - - - - lappend added_ifaces_$lev $ifid - #clone 'uses' all it's predecessor's interfaces, so update each interface's 'usedby' list. - set ::p::${ifid}::_iface::o_usedby(i$clone_ID) $clone - } - } - set extracted_sub_dict [dict get $CLONEMAP interfaces] - dict set extracted_sub_dict level$lev [concat $existing_ifaces [set added_ifaces_$lev]] - dict set CLONEMAP interfaces $extracted_sub_dict - #lset CLONEMAP 1 $lev [concat $existing_ifaces [set added_ifaces_$lev]] - } - - #interp alias {} ::p::${IFID0}::(VIOLATE) {} ::p::internals::(VIOLATE) - - - #foreach *added* level0 interface.. - foreach ifid $added_ifaces_0 { - namespace upvar ::p::${ifid}::_iface o_methods o_methods o_properties o_properties o_variables o_variables o_constructor o_constructor o_unknown o_unknown - - - dict for {prop pdef} $o_properties { - #lassign $pdef prop default - if {[dict exists $pdef default]} { - set varspace [dict get $pdef varspace] - if {$varspace eq ""} { - set ns ::p::${clone_ID} - } else { - if {[string match "::*" $varspace]} { - set ns $varspace - } else { - set ns ::p::${clone_ID}::$varspace - } - } - - if {![info exists ${ns}::o_$prop]} { - #apply CREATORS defaults - don't trash existing state for matching property (only apply if var unset) - set ${ns}::o_$prop [dict get $pdef default] - } - } - - #! May be replaced by method of same name - if {[namespace which ::p::${clone_ID}::$prop] eq ""} { - interp alias {} ::p::${clone_ID}::$prop {} ::p::${ifid}::_iface::(GET)$prop - } - interp alias {} ::p::${clone_ID}::(GET)$prop {} ::p::${ifid}::_iface::(GET)$prop - interp alias {} ::p::${clone_ID}::(SET)$prop {} ::p::${ifid}::_iface::(SET)$prop - } - - #variables - dict for {vname vdef} $o_variables { - if {[dict exists $vdef default]} { - set varspace [dict get $vdef varspace] - if {$varspace eq ""} { - set ns ::p::${clone_ID} - } else { - if {[string match "::*" $varspace]} { - set ns $varspace - } else { - set ns ::p::${clone_ID}::$varspace - } - } - if {![info exists ${ns}::$vname]} { - set ::p::${clone_ID}::$vname [dict get $vdef default] - } - } - } - - - #update the clone object's base interface to reflect the new methods. - #upvar 0 ::p::${ifid}:: IFACE - #set methods [list] - #foreach {key mname} [array get IFACE m-1,name,*] { - # set method [lindex [split $key ,] end] - # interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method $CLONEMAP - # lappend methods $method - #} - #namespace eval ::p::${clone_ID} [list namespace export {*}$methods] - - - foreach method [dict keys $o_methods] { - - set arglist [dict get $o_methods $method arglist] - set argvals "" - foreach argspec $arglist { - if {[llength $argspec] == 2} { - set a [lindex $argspec 0] - } else { - set a $argspec - } - - if {$a eq "args"} { - append argvals " \{*\}\$args" - } else { - append argvals " \$$a" - } - } - set argvals [string trimleft $argvals] - #interp alias {} ::p::${clone_ID}::$method {} ::p::${ifid}::_iface::$method - - - #this proc directly on the object is not *just* a forwarding proc - # - it provides a context in which the 'uplevel 1' from the running interface proc runs - #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) - - #proc calls the method in the interface - which is an interp alias to the head of the implementation chain - proc ::p::${clone_ID}::$method [list _ID_ {*}$arglist] [subst { - ::p::${ifid}::_iface::$method \$_ID_ $argvals - }] - - } - #namespace eval ::p::${clone_ID} [list namespace export {*}$o_methods] - - - if {[info exists o_unknown]} { - #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown - interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$o_unknown - interp alias {} ::p::${clone_ID}::(UNKNOWN) {} ::p::${clone_ID}::$o_unknown - - #namespace eval ::p::${IID}::_iface [list namespace unknown $o_unknown] - #namespace eval ::p::${clone_ID} [list namespace unknown $o_unknown] - - } - - - #2021 - #Consider >parent with constructor that sets height - #.eg >parent .. Constructor height { - # set o_height $height - #} - #>parent .. Create >child 5 - # - >child has height 5 - # now when we peform a clone operation - it is the >parent's constructor that will run. - # A clone will get default property and var values - but not other variable values unless the constructor sets them. - #>child .. Clone >fakesibling 6 - # - >sibling has height 6 - # Consider if >child had it's own constructor created with .. Construct prior to the clone operation. - # The >child's constructor didn't run - even though we created a >fakesibling - because the paren'ts one ran instead. - # If we now add a constructor to >fakesibling - and put @next@ for constructor chaining... - # when we now do >sibling .. Create >grandchild - # - The constructor on >sibling runs first but chains to >child - the cloner aunt/uncle of the >grandchild - # (while the calling order can't be changed - the positioning of @next@ tag in the contructor can allow code to run before and/or after the chained constructors and chaining can be disabled by providing a constructor without this tag.) - # However - the args supplied in the >clone operation don't get either constructor running on the >grandchild - #(though other arguments can be manually passed) - # #!review - does this make sense? What if we add - # - #constructor for each interface called after properties initialised. - #run each interface's constructor against child object, using the args passed into this clone method. - if {[llength [set constructordef [set o_constructor]]]} { - #error - puts "!!!!!> running constructor for ifid:$ifid on clone:$clone_ID" - ::p::${ifid}::_iface::(CONSTRUCTOR) [dict create i [dict create this [list [dict get $CLONEMAP invocantdata]] ]] {*}$args - - } - - } - - - return $clone - -} - - - -interp alias {} ::p::-1::constructor {} ::p::-1::Constructor ;#for Define compatibility (snit?) -dict set ::p::-1::_iface::o_methods Constructor {arglist {arglist body}} -proc ::p::-1::Constructor {_ID_ arglist body} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - #lassign [lindex $invocant 0 ] OID alias itemCmd cmd - - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - set patterns [dict get $MAP interfaces level1] - 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 [::p::>interface .. Create ::p::ifaces::>$iid_top [list $OID]] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat $patterns $iid_top] - - #::p::predator::remap $invocant - } - set IID $iid_top - - namespace upvar ::p::${IID}::_iface o_open o_open o_constructor o_constructor o_varspace o_varspace o_varspaces o_varspaces - - - # 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 varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - 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 @this@ "\[lindex \$_ID_ 0 3]" @next@ $next] $body\n] - 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] - - #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 -} - - - -dict set ::p::-1::_iface::o_methods UsedBy {arglist {}} -proc ::p::-1::UsedBy {_ID_} { - return [array get ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_usedby] -} - - -dict set ::p::-1::_iface::o_methods Ready {arglist {}} -proc ::p::-1::Ready {_ID_} { - return [expr {![set ::p::[lindex [dict get $_ID_ i this] 0 0]::_iface::o_open]}] -} - - - -dict set ::p::-1::_iface::o_methods Destroy {arglist {{force 1}}} - -#'force' 1 indicates object command & variable will also be removed. -#'force' 0 is used when the containing namespace is being destroyed anyway - so no need to destroy cmd & var. -#this is necessary for versions of Tcl that have problems with 'unset' being called multiple times. (e.g Tcl 8.5a4) -# -proc ::p::-1::Destroy {_ID_ {force 1}} { - #puts stdout "\t\tDestroy called with _ID_:$_ID_ force:$force caller:[info level 1]" - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - - if {$OID eq "null"} { - puts stderr "warning - review code. Destroy called on object with null OID. _ID_:$_ID_" - return - } - - upvar #0 ::p::${OID}::_meta::map MAP - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - - #puts ">>>>>Explicit Destroy $cmd [clock format [clock seconds] -format %H:%M:%S] info-level-1'[info level 1]'<<<<<" ;flush stdout - - #explicit Destroy - remove traces - #puts ">>TRACES: [trace info variable $cmd]" - #foreach tinfo [trace info variable $cmd] { - # trace remove variable $cmd {*}$tinfo - #} - #foreach tinfo [trace info command $cmd] { - # trace remove command $cmd {*}$tinfo - #} - - - set _cmd [string map {::> ::} $cmd] - - #set ifaces [lindex $map 1] - set iface_stacks [dict get $MAP interfaces level0] - #set patterns [lindex $map 2] - set pattern_stacks [dict get $MAP interfaces level1] - - - - set ifaces $iface_stacks - - - set patterns $pattern_stacks - - - #set i 0 - #foreach iflist $ifaces { - # set IFID$i [lindex $iflist 0] - # incr i - #} - - - set IFTOP [lindex $ifaces end] - - set DESTRUCTOR ::p::${IFTOP}::___system___destructor - #may be a proc, or may be an alias - if {[namespace which $DESTRUCTOR] ne ""} { - set temp_ID_ [dict create i [dict create this [list [dict get $MAP invocantdata]]] context {}] - - if {[catch {$DESTRUCTOR $temp_ID_} prob]} { - #!todo - ensure correct calling order of interfaces referencing the destructor proc - - - #!todo - emit destructor errors somewhere - logger? - #puts stderr "underlying proc already removed??? ---> $prob" - #puts stderr "--------Destructor Error on interface $IFID0 of Object $OID-------------" - #puts stderr $::errorInfo - #puts stderr "---------------------" - } - } - - - #remove ourself from each interfaces list of referencers - #puts stderr "--- $ifaces" - - foreach var {ifaces patterns} { - - foreach i [set $var] { - - if {[string length $i]} { - if {$i == 2} { - #skip the >ifinfo interface which doesn't maintain a usedby list anyway. - continue - } - - if {[catch { - - upvar #0 ::p::${i}::_iface::o_usedby usedby - - array unset usedby i$OID - - - #puts "\n***>>***" - #puts "IFACE: $i usedby: $usedby" - #puts "***>>***\n" - - #remove interface if no more referencers - if {![array size usedby]} { - #puts " **************** DESTROYING unused interface $i *****" - #catch {namespace delete ::p::$i} - - #we happen to know where 'interface' object commands are kept: - - ::p::ifaces::>$i .. Destroy - - } - - } errMsg]} { - #warning - puts stderr "warning: error during destruction of object:$OID (removing usedby reference for interface $i) ([lindex [dict get $MAP invocantdata] 3]) \n $errMsg" - } - } - - } - - } - - set ns ::p::${OID} - #puts "-- destroying objects below namespace:'$ns'" - ::p::internals::DestroyObjectsBelowNamespace $ns - #puts "--.destroyed objects below '$ns'" - - - #set ns ::p::${OID}::_sub - #call .. Destroy on each thing that looks like a pattern object anywhere below our 'user-area' namespace - #( ::p::OBJECT::$OID ) - #puts "\n******** [clock format [clock seconds] -format %H:%M:%S] destroyingobjectsbelownamespace ns: $ns *****\n" - #::p::internals::DestroyObjectsBelowNamespace $ns - - #same for _meta objects (e.g Methods,Properties collections) - #set ns ::p::${OID}::_meta - #::p::internals::DestroyObjectsBelowNamespace $ns - - - - #foreach obj [info commands ${ns}::>*] { - # #Assume it's one of ours, and ask it to die. - # catch {::p::meta::Destroy $obj} - # #catch {$cmd .. Destroy} - #} - #just in case the user created subnamespaces.. kill objects there too. - #foreach sub [namespace children $ns] { - # ::p::internals::DestroyObjectsBelowNamespace $sub - #} - - - #!todo - fix. info vars on the namespace is not enough to detect references which were never set to a value! - #use info commands ::p::${OID}::_ref::* to find all references - including variables never set - #remove variable traces on REF vars - #foreach rv [info vars ::p::${OID}::_ref::*] { - # foreach tinfo [trace info variable $rv] { - # #puts "-->removing traces on $rv: $tinfo" - # trace remove variable $rv {*}$tinfo - # } - #} - - #!todo - write tests - #refs create aliases and variables at the same place - #- but variable may not exist if it was never set e.g if it was only used with info exists - foreach rv [info commands ::p::${OID}::_ref::*] { - foreach tinfo [trace info variable $rv] { - #puts "-->removing traces on $rv: $tinfo" - trace remove variable $rv {*}$tinfo - } - } - - - - - - - - #if {[catch {namespace delete $nsMeta} msg]} { - # puts stderr "-----&&&&&&&&&&&&&& ERROR deleting NS $nsMeta : $msg " - #} else { - # #puts stderr "------ -- -- -- -- deleted $nsMeta " - #} - - - #!todo - remove - #temp - #catch {interp alias "" ::>$OID ""} - - if {$force} { - #rename $cmd {} - - #removing the alias will remove the command - even if it's been renamed - interp alias {} $alias {} - - #if {[catch {rename $_cmd {} } why]} { - # #!todo - work out why some objects don't have matching command. - # #puts stderr "\t rename $_cmd {} failed" - #} else { - # puts stderr "\t rename $_cmd {} SUCCEEDED!!!!!!!!!!" - #} - - } - - set refns ::p::${OID}::_ref - #puts "[clock format [clock seconds] -format %H:%M:%S] - tidying up namespace $refns" - #puts "- children: [llength [namespace children $refns]]" - #puts "- vars : [llength [info vars ${refns}::*]]" - #puts "- commands: [llength [info commands ${refns}::*]]" - #puts "- procs : [llength [info procs ${refns}::*]]" - #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" - #puts "- matching command: [llength [info commands ${refns}]]" - #puts "[clock format [clock seconds] -format %H:%M:%S] - tidyup DONE $refns" - - - #foreach v [info vars ${refns}::*] { - # unset $v - #} - #foreach p [info procs ${refns}::*] { - # rename $p {} - #} - #foreach a [lsearch -all -inline [interp aliases {}] ${refns}::*] { - # interp alias {} $a {} - #} - - - #set ts1 [clock seconds] - #puts "[clock format $ts1 -format %H:%M:%S] $cmd about to delete $refns." - #puts "- children: [llength [namespace children $refns]]" - #puts "- vars : [llength [info vars ${refns}::*]]" - - #puts "- commands: [llength [info commands ${refns}::*]]" - #puts "- procs : [llength [info procs ${refns}::*]]" - #puts "- aliases : [llength [lsearch -all -inline [interp aliases {}] ${refns}::*]]" - #puts "- exact command: [info commands ${refns}]" - - - - - #puts "--delete ::p::${OID}::_ref" - if {[namespace exists ::p::${OID}::_ref]} { - #could just catch.. but would rather know if there's some other weird reason the namespace can't be deleted. - namespace delete ::p::${OID}::_ref:: - } - set ts2 [clock seconds] - #puts "[clock format $ts2 -format %H:%M:%S] $cmd deleted $refns. ELAPSED: [expr {$ts2 - $ts1}]" - - - #delete namespace where instance variables reside - #catch {namespace delete ::p::$OID} - namespace delete ::p::$OID - - #puts "...... destroyed $cmd [clock format [clock seconds] -format %H:%M:%S] <<<<<" ;flush stdout - return -} - - -interp alias {} ::p::-1::destructor {} ::p::-1::Destructor ;#for Define compatibility - - -dict set ::p::-1::_iface::o_methods Destructor {arglist {args}} -#!todo - destructor arguments? e.g to be able to mark for destruction on next sweep of some collector as opposed to immediate destruction? -#install a Destructor on the invocant's open level1 interface. -proc ::p::-1::Destructor {_ID_ args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - #lassign [lindex $map 0] OID alias itemCmd cmd - - set patterns [dict get $MAP interfaces level1] - - if {[llength $args] > 2} { - error "too many arguments to 'Destructor' - expected at most 2 (arglist body)" - } - - set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - error "NOT TESTED" - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] - - #::p::predator::remap $invocant - } - - - set ::p::${IID}::_iface::o_destructor_body [lindex $args end] - - if {[llength $args] > 1} { - #!todo - allow destructor args(?) - set arglist [lindex $args 0] - } else { - set arglist [list] - } - - set ::p::${IID}::_iface::o_destructor_args $arglist - - return -} - - - - - -interp alias {} ::p::-1::method {} ::p::-1::PatternMethod ;#for Define compatibility (with snit) - - -dict set ::p::-1::_iface::o_methods PatternMethod {arglist {method arglist body}} -proc ::p::-1::PatternMethod {_ID_ method arglist body} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped - - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. - 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 iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - } - set IID $iid_top - - - namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces - - - # examine the existing command-chain - set maxversion [::p::predator::method_chainhead $IID $method] - set headid [expr {$maxversion + 1}] - set THISNAME $method.$headid ;#first version will be $method.1 - - set next [::p::predator::next_script $IID $method $THISNAME $_ID_] - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - #puts stdout "!!!>!>>>>>$THISNAME VarDecls: $varDecls" - set body $varDecls\n[dict get $processed body] - #puts stderr "\t object $OID runtime_vardecls in PatternMethod $method $varDecls" - } - - - set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body[set body {}] $arglist] - - #set body [string map [::list @this@ "\[lindex \${_ID_} 0 3]" @next@ $next] $body\n] - 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[set body {}]\n] - #puts "\t\t--------------------" - #puts "\n" - #puts $body - #puts "\n" - #puts "\t\t--------------------" - proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body - - - - #pointer from method-name to head of the interface's command-chain - interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME - - - - if {$method in [dict keys $o_methods]} { - #error "patternmethod '$method' already present in interface $IID" - set msg "WARNING: patternmethod '$method' already exists on objectid $OID ($object_command). Replacing previous version. (no chaining support here yet...)" - if {[string match "*@next@*" $body]} { - append msg "\n EXTRA-WARNING: method contains @next@" - } - - puts stdout $msg - } else { - dict set o_methods $method [list arglist $arglist] - } - - #::p::-1::update_invocant_aliases $_ID_ - return -} - -#MultiMethod -#invocant_signature records the rolenames and aritys as a dispatch signature to support multimethods which act on any number of invocants -# e.g1 $obj .. MultiMethod add {these 2} $arglist $body -# e.g2 $obj .. MultiMethod add {these n} $arglist $body -# -# e.g3 $collidabletemplate .. MultiMethod collision {vehicles 2 cameras 0..n} $arglist $body -# -# for e.g3 - all vehicles & cameras involved would need to have the interface containing the method named 'collision', with the matching invocant_signature. -# (it is possible for the object, or even the same interface to contain another method named 'collision' with a different signature) -# !todo - review rules for when invocants participating in a multimethod with a particular signature, have different implementations (method from different interfaces) -# - can we avoid the overhead of checking for this at dispatch-time, and simply use which ever implementation we first encounter? -# - should we warn about or enforce a same-implementation rule for all multimethod conflicts found at the time an object-conglomeration is formed? -# - should there be before and after hooks for all invocants involved in a multimethod so they can each add behaviour independent of the shared multimethod code? -# (and how would we define the call order? - presumably as it appears in the conglomerate) -# (or could that be done with a more general method-wrapping mechanism?) -#...should multimethods use some sort of event mechanism, and/or message-passing system? -# -dict set ::p::-1::_iface::o_methods MultiMethod {arglist {method invocant_signature arglist body args}} -proc ::p::-1::MultiMethod {_ID_ method invocant_signature arglist body args} { - set invocants [dict get $_ID_ i] - - error "not implemented" -} - -dict set ::p::-1::_iface::o_methods DefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} -# we could use . to indicate no methodname - as this is one of a few highly confusing names for a method (also for example .. , # -- ) -#we can create a method named "." by using the argprotect operator -- -# e.g >x .. Method -- . {args} $body -#It can then be called like so: >x . . -#This is not guaranteed to work and is not in the test suite -#for now we'll just use a highly unlikely string to indicate no argument was supplied -proc ::p::-1::DefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { - set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_method object_command _wrapped - if {$methodname eq $non_argument_magicstring} { - return $default_method - } else { - set extracted_value [dict get $MAP invocantdata] - lset extracted_value 2 $methodname - dict set MAP invocantdata $extracted_value ;#write modified value back - #update the object's command alias to match - interp alias {} $alias {} ;#first we must delete it - interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_value ] ] context {}] - - #! $object_command was initially created as the renamed alias - so we have to do it again - rename $alias $object_command - trace add command $object_command rename [list $object_command .. Rename] - return $methodname - } -} - -dict set ::p::-1::_iface::o_methods PatternDefaultMethod {arglist {{methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"}}} -proc ::p::-1::PatternDefaultMethod {_ID_ {methodname "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4"} } { - set non_argument_magicstring "noargsupplied--9e40ec8b-bc31-4400-98b8-d48ee23746c4" - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set extracted_patterndata [dict get $MAP patterndata] - set pattern_default_method [dict get $extracted_patterndata patterndefaultmethod] - if {$methodname eq $non_argument_magicstring} { - return $pattern_default_method - } else { - dict set extracted_patterndata patterndefaultmethod $methodname - dict set MAP patterndata $extracted_patterndata - return $methodname - } -} - - -dict set ::p::-1::_iface::o_methods Method {arglist {method arglist bodydef args}} -proc ::p::-1::Method {_ID_ method arglist bodydef args} { - set invocants [dict get $_ID_ i] - - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - - 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') - - - - lassign [dict get $MAP invocantdata] OID alias default_method object_command - set interfaces [dict get $MAP interfaces level0] - - - - ################################################################################# - if 0 { - set iid_top [lindex $interfaces end] ;#!todo - get 'open' interface - set prev_open [set ::p::${iid_top}::_iface::o_open] - - set iface ::p::ifaces::>$iid_top - - set f_new 0 - if {![string length $iid_top]} { - set f_new 1 - } else { - if {[$iface . isClosed]} { - set f_new 1 - } - } - if {$f_new} { - #create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat $interfaces $iid_top] - dict set MAP interfaces $extracted_sub_dict - - } - set IID $iid_top - - } - ################################################################################# - - set IID [::p::predator::get_possibly_new_open_interface $OID] - - #upvar 0 ::p::${IID}:: IFACE - - namespace upvar ::p::${IID}::_iface o_methods o_methods o_definition o_definition o_varspace o_varspace o_varspaces o_varspaces - - - #Interface proc - # examine the existing command-chain - set maxversion [::p::predator::method_chainhead $IID $method] - set headid [expr {$maxversion + 1}] - set THISNAME $method.$headid ;#first version will be $method.1 - - if {$method ni [dict keys $o_methods]} { - dict set o_methods $method [list arglist $arglist] - } - - #next_script will call to lower interface in iStack if we are $method.1 - set next [::p::predator::next_script $IID $method $THISNAME $_ID_] ;#last parameter is caller_ID_ - #puts ">!>>$THISNAME>>>>> next: '$next'<<<<<<" - - - #implement - #----------------------------------- - set processed [dict create {*}[::p::predator::expand_var_statements $bodydef $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - set varDecls "" - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls\n[dict get $processed body] - } - - - set body [::p::predator::wrap_script_in_apply_object_namespace $o_varspace $body $arglist] - - - - - - - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - 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] - - #if {[string length $varDecls]} { - # puts stdout "\t---------------------------------------------------------------" - # puts stdout "\t----- efficiency warning - implicit var declarations used -----" - # puts stdout "\t-------- $object_command .. Method $method $arglist ---------" - # puts stdout "\t[string map [list \n \t\t\n] $body]" - # puts stdout "\t--------------------------" - #} - #invocants are stored as a nested dict in the Invocant Data parameter (_ID_) under the key 'i', and then the invocant_role - # while 'dict get $_ID_ i this' should always return a single invocant, all roles theoretically return a list of invocants fulfilling that position. - #(as specified by the @ operator during object conglomeration) - #set body [string map [::list @this@ "\[dict get \$_ID_ i this \]" @next@ $next] $body\n] - - #puts stdout "\t\t----------------------------" - #puts stdout "$body" - #puts stdout "\t\t----------------------------" - - proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $arglist] $body - - #----------------------------------- - - #pointer from method-name to head of override-chain - interp alias {} ::p::${IID}::_iface::$method {} ::p::${IID}::_iface::$THISNAME - - - #point to the interface command only. The dispatcher will supply the invocant data - #interp alias {} ::p::${OID}::$method {} ::p::${IID}::_iface::$method - set argvals "" - foreach argspec $arglist { - if {[llength $argspec] == 2} { - set a [lindex $argspec 0] - } else { - set a $argspec - } - if {$a eq "args"} { - append argvals " \{*\}\$args" - } else { - append argvals " \$$a" - } - } - set argvals [string trimleft $argvals] - #this proc directly on the object is not *just* a forwarding proc - # - it provides a context in which the 'uplevel 1' from the running interface proc runs - #This (in 2018) is faster than a namespace alias forward to an interface proc which used apply to run in the dynamically calculated namespace (it seems the dynamic namespace stopped it from byte-compiling?) - - #we point to the method of the same name in the interface - which is an interp alias to the head of the implementation chain - - proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { - ::p::${IID}::_iface::$method \$_ID_ $argvals - }] - - - if 0 { - if {[llength $argvals]} { - proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist @argv@ $argvals] { - apply {{_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@}} @ID@ @argv@ - }] - } else { - - proc ::p::${OID}::$method [list _ID_ {*}$arglist] [string map [list @ID@ [list $_ID_] @iid@ $IID @m@ $method @argl@ $arglist] { - apply [list {_ID_ @argl@} {::p::@iid@::_iface::@m@ $_ID_ @argl@} [namespace current]] @ID@ - }] - - } - } - - - #proc ::p::${OID}::$method [list _ID_ {*}$arglist] [subst { - # ::p::${IID}::_iface::$method \$_ID_ $argvals - #}] - - #todo - for o_varspaces - #install ::p::${OID}::${varspace}::$method with interp alias from ::p::${OID}::$method - #- this should work correctly with the 'uplevel 1' procs in the interfaces - - - if {[string length $o_varspace]} { - if {[string match "::*" $o_varspace]} { - namespace eval $o_varspace {} - } else { - namespace eval ::p::${OID}::$o_varspace {} - } - } - - - #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. - set colMethods ::p::${OID}::_meta::>colMethods - - if {[namespace which $colMethods] ne ""} { - if {![$colMethods . hasKey $method]} { - $colMethods . add [::p::internals::predator $_ID_ . $method .] $method - } - } - - #::p::-1::update_invocant_aliases $_ID_ - return - #::>pattern .. Create [::>pattern .. Namespace]::>method_??? - #return $method_object -} - - -dict set ::p::-1::_iface::o_methods V {arglist {{glob *}}} -proc ::p::-1::V {_ID_ {glob *}} { - set invocants [dict get $_ID_ i] - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - - - set vlist [list] - foreach IID $ifaces { - dict for {vname vdef} [set ::p::${IID}::_iface::o_variables] { - if {[string match $glob $vname]} { - lappend vlist $vname - } - } - } - - - return $vlist -} - -#experiment from http://wiki.tcl.tk/4884 -proc p::predator::pipeline {args} { - set lambda {return -level 0} - foreach arg $args { - set lambda [list apply [dict get { - toupper {{lambda input} {string toupper [{*}$lambda $input]}} - tolower {{lambda input} {string tolower [{*}$lambda $input]}} - totitle {{lambda input} {string totitle [{*}$lambda $input]}} - prefix {{lambda pre input} {string cat $pre [{*}$lambda $input]}} - suffix {{lambda suf input} {string cat [{*}$lambda $input] $suf}} - } [lindex $arg 0]] $lambda[set lambda {}] {*}[lrange $arg 1 end]] - } - return $lambda -} - -proc ::p::predator::get_apply_arg_0_oid {} { - set apply_args [lrange [info level 0] 2 end] - puts stderr ">>>>> apply_args:'$apply_args'<<<<" - set invocant [lindex $apply_args 0] - return [lindex [dict get $invocant i this] 0 0] -} -proc ::p::predator::get_oid {} { - #puts stderr "---->> [info level 1] <<-----" - set _ID_ [lindex [info level 1] 1] ;#something like ::p::17::_iface::method.1 {i {this { {16 ::p::16 item ::>thing {} } } }} arg1 arg2 - tailcall lindex [dict get $_ID_ i this] 0 0 -} - -#todo - make sure this is called for all script installations - e.g propertyread etc etc -#Add tests to check code runs in correct namespace -#review - how does 'Varspace' command affect this? -proc ::p::predator::wrap_script_in_apply_object_namespace {varspace body arglist} { - #use 'lindex $a 0' to make sure we only get the variable name. (arglist may have defaultvalues) - set arglist_apply "" - append arglist_apply "\$_ID_ " - foreach a $arglist { - if {$a eq "args"} { - append arglist_apply "{*}\$args" - } else { - append arglist_apply "\$[lindex $a 0] " - } - } - #!todo - allow fully qualified varspaces - if {[string length $varspace]} { - if {[string match ::* $varspace]} { - return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} $varspace \] $arglist_apply" - } else { - #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply \]\n" - return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@::$varspace \] $arglist_apply" - } - } else { - #return "uplevel 1 \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]\n" - #return "tailcall try \[list apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply \]" - - set script "tailcall apply \[list \{_ID_" - - if {[llength $arglist]} { - append script " $arglist" - } - append script "\} \{" - append script $body - append script "\} ::p::@OID@\] " - append script $arglist_apply - #puts stderr "\n88888888888888888888888888\n\t$script\n" - #puts stderr "\n77777777777777777777777777\n\ttailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" - #return $script - - - #----------------------------------------------------------------------------- - # 2018 candidates - # - #return "tailcall apply \[list \[list _ID_ $arglist\] \{$body\} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled - #return "tailcall apply \[list {_ID_ $arglist} {$body} ::p::@OID@ \] $arglist_apply" ;#ok - but doesn't seem to be bytecompiled - - - #this has problems with @next@ arguments! (also script variables will possibly interfere with each other) - #faster though. - #return "uplevel 1 \{$body\}" - return "uplevel 1 [list $body]" - #----------------------------------------------------------------------------- - - - - - #set script "apply \[list \[list _ID_ $arglist\] \{$body\}\] $arglist_apply" - #return "uplevel 1 \{$script\}" - - #return "puts stderr --\[info locals\]-- ;apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail - #return "apply \[list {_ID_ $arglist} {$body} ::p::\[p::predator::get_oid\] \] $arglist_apply" ;#fail - - - - #return "tailcall apply { {_ID_ $arglist} {$body} ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] } $arglist_apply" ;#wrong - - #return "tailcall apply \[list {_ID_ $arglist} {apply { {_ID_ $arglist} {$body}} $arglist_apply } ::p::@OID@ \] $arglist_apply" ;#wrong ns - - - #experiment with different dispatch mechanism (interp alias with 'namespace inscope') - #----------- - #return "apply { {_ID_ $arglist} {$body}} $arglist_apply" - - - #return "uplevel 1 \{$body\}" ;#do nothing - - #---------- - - #return "tailcall namespace inscope ::p::@OID@ \{apply \{\{_ID_ $arglist\} \{$body\}\}\} $arglist_apply" ;#wrong! doesn't evaluate in the correct namespace (wrong _ID_ ??) - - #return "tailcall apply \{\{_ID_ $arglist\} \{namespace inscope ::p::@OID@ \{$body\}\} \} $arglist_apply" ;#wrong - _ID_ now not available in $body - - #return "tailcall apply \{\{ns _ID_ $arglist\} \{ apply \[list {_ID_ $arglist} \{$body\} \$ns \] $arglist_apply \} \} ::p::@OID@ $arglist_apply" ;#no quicker - - #return "tailcall " - - - } -} - - -#Handle 'var' and 'varspace' declarations in method/constructor/destructor/propertyread etc bodies. -#expand 'var' statements inline in method bodies -#The presence of a var statement in any code-branch will cause the processor to NOT insert the implicit default var statements. -# -#concept of 'varspace' to allow separation and/or sharing of contexts for cooperating interfaces -#WARNING: within methods etc, varspace statements affect all following var statements.. i.e varspace not affected by runtime code-branches! -# e.g if 1 {varspace x} else {varspace y} will always leave 'varspace y' in effect for following statements. -#Think of var & varspace statments as a form of compile-time 'macro' -# -#caters for 2-element lists as arguments to var statement to allow 'aliasing' -#e.g var o_thing {o_data mydata} -# this will upvar o_thing as o_thing & o_data as mydata -# -proc ::p::predator::expand_var_statements {rawbody {varspace ""}} { - set body {} - - #keep count of any explicit var statments per varspace in 'numDeclared' array - # don't initialise numDeclared. We use numDeclared keys to see which varspaces have var statements. - - #default varspace is "" - #varspace should only have leading :: if it is an absolute namespace path. - - - foreach ln [split $rawbody \n] { - set trimline [string trim $ln] - - if {$trimline eq "var"} { - #plain var statement alone indicates we don't have any explicit declarations in this branch - # and we don't want implicit declarations for the current varspace either. - #!todo - implement test - - incr numDeclared($varspace) - - #may be further var statements e.g - in other code branches - #return [list body $rawbody varspaces_with_explicit_vars 1] - } elseif {([string range $trimline 0 2] eq "var") && ([string is space [string index $trimline 3]])} { - - #append body " upvar #0 " - #append body " namespace upvar ::p::\[lindex \$_ID_ 0 0 \]${varspace} " - #append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]${varspace} " - - if {$varspace eq ""} { - append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\] " - } else { - if {[string match "::*" $varspace]} { - append body " namespace upvar $varspace " - } else { - append body " namespace upvar ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::${varspace} " - } - } - - #any whitespace before or betw var names doesn't matter - about to use as list. - foreach varspec [string range $trimline 4 end] { - lassign [concat $varspec $varspec] var alias ;#var == alias if varspec only 1 element. - ##append body "::p::\[lindex \$_ID_ 0 0 \]::${varspace}$var $alias " - #append body "::p::\[lindex \$_ID_ 0 0 \]${varspace}$var $alias " - - append body "$var $alias " - - } - append body \n - - incr numDeclared($varspace) - } elseif {([string range $trimline 0 7] eq "varspace") && ([string is space -strict [string index $trimline 8]])} { - #2021 REVIEW - why do we even need 'varspace x' commands in bodies? - just use 'namespace eval x' ??? - #it is assumed there is a single word following the 'varspace' keyword. - set varspace [string trim [string range $trimline 9 end]] - - if {$varspace in [list {{}} {""}]} { - set varspace "" - } - if {[string length $varspace]} { - #set varspace ::${varspace}:: - #no need to initialize numDeclared($varspace) incr will work anyway. - #if {![info exists numDeclared($varspace)]} { - # set numDeclared($varspace) 0 - #} - - if {[string match "::*" $varspace]} { - append body "namespace eval $varspace {} \n" - } else { - append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]::$varspace {} \n" - } - - #puts "!!!! here~! namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} " - #append body "namespace eval ::p::\[lindex \$_ID_ 0 0\]$varspace {} \n" - #append body "namespace eval ::p::\[lindex \[dict get \$_ID_ i this\] 0 0\]$varspace {} \n" - - #append body "puts \"varspace: created ns ::p::\[lindex \$_ID_ 0 0\]$varspace \"\n" - } - #!review - why? why do we need the magic 'default' name instead of just using the empty string? - #if varspace argument was empty string - leave it alone - } else { - append body $ln\n - } - } - - - - set varspaces [array names numDeclared] - return [list body $body varspaces_with_explicit_vars $varspaces] -} - - - - -#Interface Variables -dict set ::p::-1::_iface::o_methods IV {arglist {{glob *}}} -proc ::p::-1::IV {_ID_ {glob *}} { - set invocants [dict get $_ID_ i] - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - - #!todo - test - #return [dict keys ::p::${OID}::_iface::o_variables $glob] - - set members [list] - foreach vname [dict keys [set ::p::${OID}::_iface::o_variables]] { - if {[string match $glob $vname]} { - lappend members $vname - } - } - return $members -} - - -dict set ::p::-1::_iface::o_methods Methods {arglist {{idx ""}}} -proc ::p::-1::Methods {_ID_ {idx ""}} { - set invocants [dict get $_ID_ i] - set this_invocant [lindex [dict get $invocants this] 0] - lassign $this_invocant OID _etc - #set map [dict get $this_info map] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - set col ::p::${OID}::_meta::>colMethods - - if {[namespace which $col] eq ""} { - patternlib::>collection .. Create $col - foreach IID $ifaces { - foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { - if {![$col . hasIndex $m]} { - #todo - create some sort of lazy-evaluating method object? - #set arglist [dict get [set ::p::${IID}::iface::o_methods] $m arglist] - $col . add [::p::internals::predator $_ID_ . $m .] $m - } - } - } - } - - if {[string length $idx]} { - return [$col . item $idx] - } else { - return $col - } -} - -dict set ::p::-1::_iface::o_methods M {arglist {}} -proc ::p::-1::M {_ID_} { - set invocants [dict get $_ID_ i] - set this_invocant [lindex [dict get $invocants this] 0] - lassign $this_invocant OID _etc - #set map [dict get $this_info map] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - set members [list] - foreach IID $ifaces { - foreach m [dict keys [set ::p::${IID}::_iface::o_methods]] { - lappend members $m - } - } - return $members -} - - -#review -#Interface Methods -dict set ::p::-1::_iface::o_methods IM {arglist {{glob *}}} -proc ::p::-1::IM {_ID_ {glob *}} { - set invocants [dict get $_ID_ i] - set this_invocant [lindex [dict get $invocants this] 0] - lassign $this_invocant OID _etc - #set map [dict get $this_info map] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - - - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - return [dict keys [set ::p::${OID}::_iface::o_methods] $glob] - -} - - - -dict set ::p::-1::_iface::o_methods InterfaceStacks {arglist {}} -proc ::p::-1::InterfaceStacks {_ID_} { - upvar #0 ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map MAP - return [dict get $MAP interfaces level0] -} - - -dict set ::p::-1::_iface::o_methods PatternStacks {arglist {}} -proc ::p::-1::PatternStacks {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - return [dict get $MAP interfaces level1] -} - - -#!todo fix. need to account for references which were never set to a value -dict set ::p::-1::_iface::o_methods DeletePropertyReferences {arglist {}} -proc ::p::-1::DeletePropertyReferences {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - set cleared_references [list] - set refvars [info vars ::p::${OID}::_ref::*] - #unsetting vars will clear traces anyway - but we wish to avoid triggering the 'unset' traces - so we will explicitly remove all traces 1st. - foreach rv $refvars { - foreach tinfo [trace info variable $rv] { - set ops {}; set cmd {} - lassign $tinfo ops cmd - trace remove variable $rv $ops $cmd - } - unset $rv - lappend cleared_references $rv - } - - - return [list deleted_property_references $cleared_references] -} - -dict set ::p::-1::_iface::o_methods DeleteMethodReferences {arglist {}} -proc ::p::-1::DeleteMethodReferences {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - set cleared_references [list] - - set iflist [dict get $MAP interfaces level0] - set iflist_reverse [lreferse $iflist] - #set iflist [dict get $MAP interfaces level0] - - - set refcommands [info commands ::p::${OID}::_ref::*] - foreach c $refcommands { - set reftail [namespace tail $c] - set field [lindex [split $c +] 0] - set field_is_a_method 0 - foreach IFID $iflist_reverse { - if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { - set field_is_a_method 1 - break - } - } - if {$field_is_a_method} { - #what if it's also a property? - interp alias {} $c {} - lappend cleared_references $c - } - } - - - return [list deleted_method_references $cleared_references] -} - - -dict set ::p::-1::_iface::o_methods DeleteReferences {arglist {}} -proc ::p::-1::DeleteReferences {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_method this - - set result [dict create] - dict set result {*}[$this .. DeletePropertyReferences] - dict set result {*}[$this .. DeleteMethodReferences] - - return $result -} - -## -#Digest -# -#!todo - review -# -> a variable containing empty string is the same as a non existant variable as far as digest is concerned.. is that bad? (probably!) -# -#!todo - write tests - check that digest changes when properties of contained objects change value -# -#!todo - include method/property/interfaces in digest calc, or provide a separate more comprehensive digest method? -# -dict set ::p::-1::_iface::o_methods Digest {arglist {args}} -proc ::p::-1::Digest {_ID_ args} { - set invocants [dict get $_ID_ i] - # md5 c-version is faster than md4 tcl version... and more likely to be required in the interp for some other purpose anyway. - #set this_invocant [lindex [dict get $invocants this] 0] - #lassign $this_invocant OID _etc - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] _OID alias default_method this - - - set interface_ids [dict get $MAP interfaces level0] - set IFID0 [lindex $interface_ids end] - - set known_flags {-recursive -algorithm -a -indent} - set defaults {-recursive 1 -algorithm md5 -indent ""} - if {[dict exists $args -a] && ![dict exists $args -algorithm]} { - dict set args -algorithm [dict get $args -a] - } - - set opts [dict merge $defaults $args] - foreach key [dict keys $opts] { - if {$key ni $known_flags} { - error "unknown option $key. Expected only: $known_flags" - } - } - - - set known_algos {"" raw RAW none NONE md5 MD5 sha256 SHA256} - if {[dict get $opts -algorithm] ni $known_algos} { - error "call to Digest with unknown -algorithm [dict get $opts -algorithm]. Expected one of: $known_algos" - } - set algo [string tolower [dict get $opts -algorithm]] - - # append comma for each var so that all changes in adjacent vars detectable. - # i.e set x 34; set y 5 - # must be distinguishable from: - # set x 3; set y 45 - - if {[dict get $opts -indent] ne ""} { - set state "" - set indent "[dict get $opts -indent]" - } else { - set state "---\n" - set indent " " - } - append state "${indent}object_command: $this\n" - set indent "${indent} " - - #append state "[lindex [interp alias {} $alias] 1]\n" ;#at the very least, include the object's interface state. - append state "${indent}interfaces: [dict get $MAP interfaces]\n";#at the very least, include the object's interface state. - - - - - #!todo - recurse into 'varspaces' - set varspaces_found [list] - append state "${indent}interfaces:\n" - foreach IID $interface_ids { - append state "${indent} - interface: $IID\n" - namespace upvar ::p::${IID}::_iface o_varspace local_o_varspace o_varspaces local_o_varspaces - append state "${indent} varspaces:\n" - foreach vs $local_o_varspaces { - if {$vs ni $varspaces_found} { - lappend varspaces_found $vs - append state "${indent} - varspace: $vs\n" - } - } - } - - append state "${indent}vars:\n" - foreach var [info vars ::p::${OID}::*] { - append state "${indent} - [namespace tail $var] : \"" - if {[catch {append state "[set $var]"}]} { - append state "[array get $var]" - } - append state "\"\n" - } - - if {[dict get $opts -recursive]} { - append state "${indent}sub-objects:\n" - set subargs $args - dict set subargs -indent "$indent " - foreach obj [info commands ::p::${OID}::>*] { - append state "[$obj .. Digest {*}$subargs]\n" - } - - append state "${indent}sub-namespaces:\n" - set subargs $args - dict set subargs -indent "$indent " - foreach ns [namespace children ::p::${OID}] { - append state "${indent} - namespace: $ns\n" - foreach obj [info commands ${ns}::>*] { - append state "[$obj .. Digest {*}$subargs]\n" - } - } - } - - - if {$algo in {"" raw none}} { - return $state - } else { - if {$algo eq "md5"} { - package require md5 - return [::md5::md5 -hex $state] - } elseif {$algo eq "sha256"} { - package require sha256 - return [::sha2::sha256 -hex $state] - } elseif {$algo eq "blowfish"} { - package require patterncipher - patterncipher::>blowfish .. Create >b1 - set [>b1 . key .] 12341234 - >b1 . encrypt $state -final 1 - set result [>b1 . ciphertext] - >b1 .. Destroy - - } elseif {$algo eq "blowfish-binary"} { - - } else { - error "can't get here" - } - - } -} - - -dict set ::p::-1::_iface::o_methods Variable {arglist {varname args}} -proc ::p::-1::Variable {_ID_ varname args} { - set invocants [dict get $_ID_ i] - - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - #this interface itself is always a co-invocant - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set interfaces [dict get $MAP interfaces level0] - - #set existing_IID [lindex $map 1 0 end] - set existing_IID [lindex $interfaces end] - - set prev_openstate [set ::p::${existing_IID}::_iface::o_open] - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #IID changed - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - - - #update original object command - set ::p::${IID}::_iface::o_open 0 - } else { - set ::p::${IID}::_iface::o_open $prev_openstate - } - - set varspace [set ::p::${IID}::_iface::o_varspace] ;#varspace at the time this Variable was added (may differ from default for interface) - - if {[llength $args]} { - #!assume var not already present on interface - it is an error to define twice (?) - #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] - dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] - - - #Implement if there is a default - #!todo - correct behaviour when overlaying on existing object with existing var of this name? - #if {[string length $varspace]} { - # set ::p::${OID}::${varspace}::$varname [lindex $args 0] - #} else { - set ::p::${OID}::$varname [lindex $args 0] - #} - } else { - #lappend ::p::${IID}::_iface::o_variables [list $varname] - dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] - } - - #varspace '_iface' - - return -} - - -#interp alias {} ::p::-1::variable {} ::p::-1::PatternVariable ;#for Define compatibility - -dict set ::p::-1::_iface::o_methods PatternVariable {arglist {varname args}} -proc ::p::-1::PatternVariable {_ID_ varname args} { - set invocants [dict get $_ID_ i] - - #set invocant_alias [lindex [dict get $invocants this] 0] - #set invocant [lindex [interp alias {} $invocant_alias] 1] - ##this interface itself is always a co-invocant - #lassign [lindex $invocant 0 ] OID alias itemCmd cmd - - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - - - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] ;#!todo - get 'open' interface. - 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 iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat $patterns $iid_top] - } - set IID $iid_top - - set varspace [set ::p::${IID}::_iface::o_varspace] ;#record varspace against each variable, because default varspace for interface can be modified. - - - if {[llength $args]} { - #lappend ::p::${IID}::_iface::o_variables [list $varname [lindex $args 0]] - dict set ::p::${IID}::_iface::o_variables $varname [list default [lindex $args 0] varspace $varspace] - } else { - dict set ::p::${IID}::_iface::o_variables $varname [list varspace $varspace] - } - - return -} - -dict set ::p::-1::_iface::o_methods Varspaces {arglist args} -proc ::p::-1::Varspaces {_ID_ args} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - if {![llength $args]} { - #query - set iid_top [lindex [dict get $MAP interfaces level0] end] - set iface ::p::ifaces::>$iid_top - if {![string length $iid_top]} { - error "Cannot query Varspaces because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " - } elseif {[$iface . isClosed]} { - error "Cannot query Varspaces because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " - } - return [set ::p::${iid_top}::_iface::o_varspaces] - } - set IID [::p::predator::get_possibly_new_open_interface $OID] - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces - - set varspaces $args - foreach vs $varspaces { - if {[string length $vs] && ($vs ni $o_varspaces)} { - if {[string match ::* $vs} { - namespace eval $vs {} - } else { - namespace eval ::p::${OID}::$vs {} - } - lappend o_varspaces $vs - } - } - return $o_varspaces -} - -#set or query Varspace. Error to query a closed interface, but if interface closed when writing, itwill create a new open interface -dict set ::p::-1::_iface::o_methods Varspace {arglist args} -# set the default varspace for the interface, so that new methods/properties refer to it. -# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. -proc ::p::-1::Varspace {_ID_ args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - if {![llength $args]} { - #query - set iid_top [lindex [dict get $MAP interfaces level0] end] - set iface ::p::ifaces::>$iid_top - if {![string length $iid_top]} { - error "Cannot query Varspace because no top level interface on object:[lindex [dict get $MAP invocantdata] 3] " - } elseif {[$iface . isClosed]} { - error "Cannot query Varspace because top level interface (id:$iid_top) is closed on object:[lindex [dict get $MAP invocantdata] 3] " - } - return [set ::p::${iid_top}::_iface::o_varspace] - } - set varspace [lindex $args 0] - - #set interfaces [dict get $MAP interfaces level0] - #set iid_top [lindex $interfaces end] - - set IID [::p::predator::get_possibly_new_open_interface $OID] - - - #namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces - - if {[string length $varspace]} { - #ensure namespace exists !? do after list test? - if {[string match ::* $varspace]} { - namespace eval $varspace {} - } else { - namespace eval ::p::${OID}::$varspace {} - } - if {$varspace ni $o_varspaces} { - lappend o_varspaces $varspace - } - } - set o_varspace $varspace -} - - -proc ::p::predator::get_possibly_new_open_interface {OID} { - #we need to re-upvar MAP rather than using a parameter - as we need to write back to it - upvar #0 ::p::${OID}::_meta::map MAP - set interfaces [dict get $MAP interfaces level0] - set iid_top [lindex $interfaces end] - - - 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 - #puts stderr ">>>>creating new interface $iid_top" - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat $interfaces $iid_top] - dict set MAP interfaces $extracted_sub_dict - } - - return $iid_top -} - - - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PatternVarspace {arglist {varspace args}} -# set the default varspace for the interface, so that new methods/properties refer to it. -# varspace may be switched in between various additions of methods/properties so that different methods/properties are using different varspaces. -proc ::p::-1::PatternVarspace {_ID_ varspace args} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] - - 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 iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - } - set IID $iid_top - - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_varspaces o_varspaces - if {[string length $varspace]} { - if {$varspace ni $o_varspaces} { - lappend o_varspaces $varspace - } - } - #o_varspace is the currently active varspace - set o_varspace $varspace - -} -################################################################################################################################################### - -#get varspace and default from highest interface - return all interface ids which define it -dict set ::p::-1::_iface::o_methods GetPropertyInfo {arglist {{propnamepattern *}}} -proc ::p::-1::GetPropertyInfo {_ID_ {propnamepattern *}} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set interfaces [dict get $MAP interfaces level0] - - array set propinfo {} - set found_property_names [list] - #start at the lowest and work up (normal storage order of $interfaces) - foreach iid $interfaces { - set propinfodict [set ::p::${iid}::_iface::o_properties] - set matching_propnames [dict keys $propinfodict $propnamepattern] - foreach propname $matching_propnames { - if {$propname ni $found_property_names} { - lappend found_property_names $propname - } - lappend propinfo($propname,interfaces) $iid - ;#These 2 values for this $propname are overwritten for each iid in the outer loop - we are only interested in the last one - if {[dict exists $propinfodict $propname default]} { - set propinfo($propname,default) [dict get $propinfodict $propname default] - } - set propinfo($propname,varspace) [dict get $propinfodict $propname varspace] - } - } - - set resultdict [dict create] - foreach propname $found_property_names { - set fields [list varspace $propinfo($propname,varspace)] - if {[array exists propinfo($propname,default)]} { - lappend fields default [set propinfo($propname,default)] - } - lappend fields interfaces $propinfo($propname,interfaces) - dict set resultdict $propname $fields - } - return $resultdict -} - - -dict set ::p::-1::_iface::o_methods GetTopPattern {arglist args} -proc ::p::-1::GetTopPattern {_ID_ args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set interfaces [dict get $MAP interfaces level1] - set iid_top [lindex $interfaces end] - if {![string length $iid_top]} { - lassign [dict get $MAP invocantdata] OID _alias _default_method object_command - error "No installed level1 interfaces (patterns) for object $object_command" - } - return ::p::ifaces::>$iid_top -} - - - -dict set ::p::-1::_iface::o_methods GetTopInterface {arglist args} -proc ::p::-1::GetTopInterface {_ID_ args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set iid_top [lindex [dict get $MAP interfaces level0] end] - if {![string length $iid_top]} { - lassign [dict get $MAP invocantdata] OID _alias _default_method object_command - error "No installed level0 interfaces for object $object_command" - } - return ::p::ifaces::>$iid_top -} - - -dict set ::p::-1::_iface::o_methods GetExpandableInterface {arglist args} -proc ::p::-1::GetExpandableInterface {_ID_ args} { - -} - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods Property {arglist {property args}} -proc ::p::-1::Property {_ID_ property args} { - #puts stderr "::p::-1::Property called with _ID_: '$_ID_' property:$property args:$args" - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - if {[llength $args] > 1} { - error ".. Property expects 1 or 2 arguments only. (>object .. Property propertyname ?default?)" - } - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set interfaces [dict get $MAP interfaces level0] - set iid_top [lindex $interfaces end] - - set prev_openstate [set ::p::${iid_top}::_iface::o_open] - - set iface ::p::ifaces::>$iid_top - - - if {(![string length $iid_top]) || ([$iface . isClosed])} { - #create a new interface - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat $interfaces $iid_top] - dict set MAP interfaces $extracted_sub_dict - } - set IID $iid_top - - - namespace upvar ::p::${IID}::_iface o_variables o_variables o_properties o_properties o_methods o_methods o_varspace o_varspace - - - set maxversion [::p::predator::method_chainhead $IID (GET)$property] - set headid [expr {$maxversion + 1}] - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 - - - if {$headid == 1} { - #implementation - #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property - - #if {$o_varspace eq ""} { - # set ns ::p::${OID} - #} else { - # if {[string match "::*" $o_varspace]} { - # set ns $o_varspace - # } else { - # set ns ::p::${OID}::$o_varspace - # } - #} - #proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace %ns% $ns] [info body ::p::predator::getprop_template_immediate]] - - proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace ] [info body ::p::predator::getprop_template]] - - - #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property - proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] - - - #chainhead pointers - interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 - interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 - - - } - - if {($property ni [dict keys $o_methods])} { - interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property - } - - - - #installation on object - - #namespace eval ::p::${OID} [list namespace export $property] - - - - #obsolete? - #if {$property ni [P $_ID_]} { - #only link objects (GET)/(SET) for this property if property not present on any of our other interfaces - #interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property $invocant - #interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property $invocant - #} - - #link main (GET)/(SET) to this interface - interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property - interp alias {} ::p::${OID}::(SET)$property {} ::p::${IID}::_iface::(SET)$property - - #Only install property if no method of same name already installed here. - #(Method takes precedence over property because property always accessible via 'set' reference) - #convenience pointer to chainhead pointer. - if {$property ni [M $_ID_]} { - interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property - } else { - #property with same name as method - we need to make sure the refMisuse_traceHandler is fixed - - - } - - - set varspace [set ::p::${IID}::_iface::o_varspace] - - - - #Install the matching Variable - #!todo - which should take preference if Variable also given a default? - #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { - # set o_variables [lreplace $o_variables $posn $posn o_$property] - #} else { - # lappend o_variables [list o_$property] - #} - dict set o_variables o_$property [list varspace $varspace] - - - - - if {[llength $args]} { - #should store default once only! - #set IFINFO(v,default,o_$property) $default - - set default [lindex $args end] - - dict set o_properties $property [list default $default varspace $varspace] - - #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { - # set o_properties [lreplace $o_properties $posn $posn [list $property $default]] - #} else { - # lappend o_properties [list $property $default] - #} - - if {$varspace eq ""} { - set ns ::p::${OID} - } else { - if {[string match "::*" $varspace]} { - set ns $varspace - } else { - set ns ::p::${OID}::$o_varspace - } - } - - set ${ns}::o_$property $default - #set ::p::${OID}::o_$property $default - } else { - - #if {[set posn [lsearch -index 0 $o_properties $property]] >= 0} { - # set o_properties [lreplace $o_properties $posn $posn [list $property]] - #} else { - # lappend o_properties [list $property] - #} - dict set o_properties $property [list varspace $varspace] - - - #variable ::p::${OID}::o_$property - } - - - - - - #if the metainfo collection exists, update it. Don't worry if nonexistant as it will be created if needed. - #!todo - mark interface dirty (not ready?) instead? - would need all colProperties methods to respect dirty flag & synchronize as needed. (object filter?) - #catch {::p::OBJECT::${OID}::colProperties add [::p::internals::predator $invocant . $property .] $property} - - set colProperties ::p::${OID}::_meta::>colProperties - if {[namespace which $colProperties] ne ""} { - if {![$colProperties . hasKey $property]} { - $colProperties . add [::p::internals::predator $_ID_ . $property .] $property - } - } - - return -} -################################################################################################################################################### - - - -################################################################################################################################################### - -################################################################################################################################################### -interp alias {} ::p::-1::option {} ::p::-1::PatternProperty ;#for Define compatibility -dict set ::p::-1::_iface::o_methods PatternProperty {arglist {property args}} -proc ::p::-1::PatternProperty {_ID_ property args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - set patterns [dict get $MAP interfaces level1] - set iid_top [lindex $patterns end] - - set iface ::p::ifaces::>$iid_top - - if {(![string length $iid_top]) || ([$iface . isClosed])} { - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat $patterns $iid_top] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat $patterns $iid_top] - } - set IID $iid_top - - namespace upvar ::p::${IID}::_iface o_properties o_properties o_variables o_variables o_varspace o_varspace - - - set maxversion [::p::predator::method_chainhead $IID (GET)$property] - set headid [expr {$maxversion + 1}] - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 - - - - if {$headid == 1} { - #implementation - #interp alias {} ::p::${IID}::_iface::(GET)$property.1 {} ::p::predator::getprop $property - proc ::p::${IID}::_iface::(GET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::getprop_template]] - #interp alias {} ::p::${IID}::_iface::(SET)$property.1 {} ::p::predator::setprop $property - proc ::p::${IID}::_iface::(SET)$property.1 {_ID_ args} [string map [list %prop% $property %varspace% $o_varspace] [info body ::p::predator::setprop_template]] - - - #chainhead pointers - interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.1 - interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.1 - - } - - if {($property ni [dict keys [set ::p::${IID}::_iface::o_methods]])} { - interp alias {} ::p::${IID}::_iface::$property {} ::p::${IID}::_iface::(GET)$property - } - - set varspace [set ::p::${IID}::_iface::o_varspace] - - #Install the matching Variable - #!todo - which should take preference if Variable also given a default? - #if {[set posn [lsearch -index 0 $o_variables o_$property]] >= 0} { - # set o_variables [lreplace $o_variables $posn $posn o_$property] - #} else { - # lappend o_variables [list o_$property] - #} - dict set o_variables o_$property [list varspace $varspace] - - set argc [llength $args] - - if {$argc} { - if {$argc == 1} { - set default [lindex $args 0] - dict set o_properties $property [list default $default varspace $varspace] - } else { - #if more than one arg - treat as a dict of options. - if {[dict exists $args -default]} { - set default [dict get $args -default] - dict set o_properties $property [list default $default varspace $varspace] - } else { - #no default value - dict set o_properties $property [list varspace $varspace] - } - } - #! only set default for property... not underlying variable. - #lappend ::p::${IID}::_iface::o_variables [list o_$property [lindex $args 0]] - } else { - dict set o_properties $property [list varspace $varspace] - } - return -} -################################################################################################################################################### - - - - - - - - - - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PatternPropertyRead {arglist {property args}} -proc ::p::-1::PatternPropertyRead {_ID_ property args} { - set invocants [dict get $_ID_ i] - - set this_invocant [lindex [dict get $_ID_ i this] 0] ;#assume only one 'this' - set OID [lindex $this_invocant 0] - #set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias defaut_command cmd - - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] - - set idxlist [::list] - if {[llength $args] == 1} { - set body [lindex $args 0] - } elseif {[llength $args] == 2} { - lassign $args idxlist body - } else { - error "wrong # args: should be \"property body\" or \"property idxlist body\"" - } - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] - - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } - - namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace - - set maxversion [::p::predator::method_chainhead $IID (GET)$property] - set headid [expr {$maxversion + 1}] - if {$headid == 1} { - set headid 2 ;#reserve 1 for the getprop of the underlying property - } - - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.1 - set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] ;#last parameter is caller_ID_ - - - #implement - #----------------------------------- - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - 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] - - - #implementation - if {![llength $idxlist]} { - proc ::p::${IID}::_iface::(GET)$property.$headid {_ID_ args} $body - } else { - #what are we trying to achieve here? .. - proc ::p::${IID}::_iface::(GET)$property.$headid [linsert $idxlist 0 _ID_] $body - } - - - #----------------------------------- - - - #adjust chain-head pointer to point to new head. - interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid - - return -} -################################################################################################################################################### - - - - - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PropertyRead {arglist {property args}} -proc ::p::-1::PropertyRead {_ID_ property args} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - - #assert $OID ne "null" - dispatcher won't call PropertyRead on a non-object(?) (presumably the call would be to 'Method' instead) - lassign [dict get $MAP invocantdata] OID alias default_command cmd - - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] - - - set idxlist [::list] - if {[llength $args] == 1} { - set body [lindex $args 0] - } elseif {[llength $args] == 2} { - lassign $args idxlist body - } else { - error "wrong # args: should be \"property body\" or \"property idxlist body\"" - } - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - - set ::p::${IID}::_iface::o_open 0 - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } - namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace - - #array set ::p::${IID}:: [::list pr,body,$property $body pr,arg,$property $idxlist pr,name,$property $property pr,iface,$property $cmd] - - - set maxversion [::p::predator::method_chainhead $IID (GET)$property] - set headid [expr {$maxversion + 1}] - if {$headid == 1} { - set headid 2 - } - set THISNAME (GET)$property.$headid ;#first version will be (GET)$property.2 - even if corresponding property is missing (we reserve $property.1 for the property itself) - - set next [::p::predator::next_script $IID (GET)$property $THISNAME $_ID_] - - #implement - #----------------------------------- - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - 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] - - proc ::p::${IID}::_iface::$THISNAME [concat _ID_ $idxlist] $body - - #----------------------------------- - - - - #pointer from prop-name to head of override-chain - interp alias {} ::p::${IID}::_iface::(GET)$property {} ::p::${IID}::_iface::(GET)$property.$headid - - - interp alias {} ::p::${OID}::(GET)$property {} ::p::${IID}::_iface::(GET)$property ;#the reference traces will call this one - in case there is both a property and a method with this name. - if {$property ni [M $_ID_]} { - interp alias {} ::p::${OID}::$property {} ::p::${IID}::_iface::(GET)$property - } -} -################################################################################################################################################### - - - - - - - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PropertyWrite {arglist {property argname body}} -proc ::p::-1::PropertyWrite {_ID_ property argname body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_command cmd - - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] ;#!todo - get 'open' interface. - - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - - set ::p::${IID}::_iface::o_open 0 - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } - namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace - - #pw short for propertywrite - #array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] - array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property] - - - set maxversion [::p::predator::method_chainhead $IID (SET)$property] - set headid [expr {$maxversion + 1}] - - set THISNAME (SET)$property.$headid - - set next [::p::predator::next_script $IID (SET)$property $THISNAME $_ID_] - - #implement - #----------------------------------- - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - 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] - - - proc ::p::${IID}::_iface::$THISNAME [list _ID_ $argname] $body - - #----------------------------------- - - - - #pointer from method-name to head of override-chain - interp alias {} ::p::${IID}::_iface::(SET)$property {} ::p::${IID}::_iface::(SET)$property.$headid -} -################################################################################################################################################### - - - - - - - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PatternPropertyWrite {arglist {property argname body}} -proc ::p::-1::PatternPropertyWrite {_ID_ property argname body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_command cmd - - - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] ;#!todo - get 'open' interface. - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set existing_ifaces [lindex $map 1 1] - set posn [lsearch $existing_ifaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $existing_ifaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $existing_ifaces $posn $posn] $IID] - - #set ::p::${IID}::_iface::o_open 0 - } else { - } - - #pw short for propertywrite - array set ::p::${IID}:: [::list pw,body,$property $body pw,arg,$property $argname pw,name,$property $property pw,iface,$property $cmd] - - - - - return - -} -################################################################################################################################################### - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PropertyUnset {arglist {property arraykeypattern body}} -proc ::p::-1::PropertyUnset {_ID_ property arraykeypattern body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_command cmd - - - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. - - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - } else { - set prev_open [set ::p::${existing_IID}::_iface::o_open] - set ::p::${IID}::_iface::o_open $prev_open - } - namespace upvar ::p::${IID}::_iface o_varspaces o_varspaces o_varspace o_varspace o_propertyunset_handlers propertyunset_handlers - #upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers - dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] - - set maxversion [::p::predator::method_chainhead $IID (UNSET)$property] - set headid [expr {$maxversion + 1}] - - set THISNAME (UNSET)$property.$headid - - set next [::p::predator::next_script $IID (UNSET)$property $THISNAME $_ID_] - - - set processed [dict create {*}[::p::predator::expand_var_statements $body $o_varspace]] - if {[llength [dict get $processed varspaces_with_explicit_vars]]} { - foreach vs [dict get $processed varspaces_with_explicit_vars] { - if {[string length $vs] && ($vs ni $o_varspaces)} { - lappend o_varspaces $vs - } - } - set body [dict get $processed body] - } else { - set varDecls [::p::predator::runtime_vardecls] ;#dynamic vardecls can access vars from all interfaces of invocant object. - set body $varDecls[dict get $processed body] - } - #set body [string map [::list @this@ "\[lindex \$_ID_ 0 3 \]" @next@ $next] $body\n] - 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] - - #note $arraykeypattern actually contains the name of the argument - if {[string trim $arraykeypattern] eq ""} { - set arraykeypattern _dontcare_ ;# - } - proc ::p::${IID}::_iface::(UNSET)$property.$headid [list _ID_ $arraykeypattern] $body - - #----------------------------------- - - - #pointer from method-name to head of override-chain - interp alias {} ::p::${IID}::_iface::(UNSET)$property {} ::p::${IID}::_iface::(UNSET)$property.$headid - -} -################################################################################################################################################### - - - - - - - - -################################################################################################################################################### - -################################################################################################################################################### -dict set ::p::-1::_iface::o_methods PatternPropertyUnset {arglist {property arraykeypattern body}} -proc ::p::-1::PatternPropertyUnset {_ID_ property arraykeypattern body} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. - - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #set ::p::${IID}::_iface::o_open 0 - } - - - upvar ::p::${IID}::_iface::o_propertyunset_handlers propertyunset_handlers - dict set propertyunset_handlers $property [list body $body arraykeypattern $arraykeypattern] - - return -} -################################################################################################################################################### - - - -#lappend ::p::-1::_iface::o_methods Implements -#!todo - some way to force overriding of any abstract (empty) methods from the source object -#e.g leave interface open and raise an error when closing it if there are unoverridden methods? - - - - - -#implementation reuse - sugar for >object .. Clone >target -dict set ::p::-1::_iface::o_methods Extends {arglist {pattern}} -proc ::p::-1::Extends {_ID_ pattern} { - if {!([string range [namespace tail $pattern] 0 0] eq ">")} { - error "'Extends' expected a pattern object" - } - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd object_command - - - tailcall $pattern .. Clone $object_command - -} -#implementation reuse - sugar for >pattern .. Create >target -dict set ::p::-1::_iface::o_methods PatternExtends {arglist {pattern}} -proc ::p::-1::PatternExtends {_ID_ pattern} { - if {!([string range [namespace tail $pattern] 0 0] eq ">")} { - error "'PatternExtends' expected a pattern object" - } - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd object_command - - - tailcall $pattern .. Create $object_command -} - - -dict set ::p::-1::_iface::o_methods Extend {arglist {{idx ""}}} -proc ::p::-1::Extend {_ID_ {idx ""}} { - puts stderr "Extend is DEPRECATED - use Expand instead" - tailcall ::p::-1::Expand $_ID_ $idx -} - -#set the topmost interface on the iStack to be 'open' -dict set ::p::-1::_iface::o_methods Expand {arglist {{idx ""}}} -proc ::p::-1::Expand {_ID_ {idx ""}} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set iid_top [lindex $interfaces end] - set iface ::p::ifaces::>$iid_top - - if {![string length $iid_top]} { - #no existing interface - create a new one - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [list $iid_top] - dict set MAP interfaces $extracted_sub_dict ;#write new interface into map - $iface . open - return $iid_top - } else { - if {[$iface . isOpen]} { - #already open.. - #assume ready to expand.. shared or not! - return $iid_top - } - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - if {[$iface . refCount] > 1} { - if {$iid_top != [set IID [::p::internals::expand_interface $iid_top ]]} { - #!warning! not exercised by test suites! - - #remove ourself from the usedby list of the previous interface - array unset ::p::${iid_top}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - #remove existing interface & add - set posn [lsearch $interfaces $iid_top] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - - - set iid_top $IID - set iface ::p::ifaces::>$iid_top - } - } - } - - $iface . open - return $iid_top -} - -dict set ::p::-1::_iface::o_methods PatternExtend {arglist {{idx ""}}} -proc ::p::-1::PatternExtend {_ID_ {idx ""}} { - puts stderr "PatternExtend is DEPRECATED - use PatternExpand instead" - tailcall ::p::-1::PatternExpand $_ID_ $idx -} - - - -#set the topmost interface on the pStack to be 'open' if it's not shared -# if shared - 'copylink' to new interface before opening for extension -dict set ::p::-1::_iface::o_methods PatternExpand {arglist {{idx ""}}} -proc ::p::-1::PatternExpand {_ID_ {idx ""}} { - set OID [::p::obj_get_this_oid $_ID_] - ::p::map $OID MAP - #puts stderr "no tests written for PatternExpand " - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - set ifaces [dict get $MAP interfaces level1] ;#level 1 interfaces - set iid_top [lindex $ifaces end] - set iface ::p::ifaces::>$iid_top - - if {![string length $iid_top]} { - #no existing interface - create a new one - set iid_top [expr {$::p::ID + 1}] ;#PREDICT the next object's id - set iface [::p::>interface .. Create ::p::ifaces::>$iid_top $OID] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [list $iid_top] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [list $iid_top] - $iface . open - return $iid_top - } else { - if {[$iface . isOpen]} { - #already open.. - #assume ready to expand.. shared or not! - return $iid_top - } - - if {[$iface . refCount] > 1} { - if {$iid_top != [set IID [::p::internals::expand_interface $iid_top]]} { - #!WARNING! not exercised by test suite! - #remove ourself from the usedby list of the previous interface - array unset ::p::${iid_top}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $ifaces $iid_top] - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $ifaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $ifaces $posn $posn] $IID] - - set iid_top $IID - set iface ::p::ifaces::>$iid_top - } - } - } - - $iface . open - return $iid_top -} - - - - - -dict set ::p::-1::_iface::o_methods Properties {arglist {{idx ""}}} -proc ::p::-1::Properties {_ID_ {idx ""}} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - set col ::p::${OID}::_meta::>colProperties - - if {[namespace which $col] eq ""} { - patternlib::>collection .. Create $col - foreach IID $ifaces { - dict for {prop pdef} [set ::p::${IID}::_iface::o_properties] { - if {![$col . hasIndex $prop]} { - $col . add [::p::internals::predator $_ID_ . $prop .] $prop - } - } - } - } - - if {[string length $idx]} { - return [$col . item $idx] - } else { - return $col - } -} - -dict set ::p::-1::_iface::o_methods P {arglist {}} -proc ::p::-1::P {_ID_} { - set invocants [dict get $_ID_ i] - set this_invocant [lindex [dict get $invocants this] 0] - lassign $this_invocant OID _etc - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set interfaces [dict get $MAP interfaces level0] ;#level 0 interfaces - - set members [list] - foreach IID $interfaces { - foreach prop [dict keys [set ::p::${IID}::_iface::o_properties]] { - lappend members $prop - } - } - return [lsort $members] - -} -#Interface Properties -dict set ::p::-1::_iface::o_methods IP {arglist {{glob *}}} -proc ::p::-1::IP {_ID_ {glob *}} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set ifaces [dict get $MAP interfaces level0] ;#level 0 interfaces - set members [list] - - foreach m [dict keys [set ::p::${OID}::_iface::o_properties]] { - if {[string match $glob [lindex $m 0]]} { - lappend members [lindex $m 0] - } - } - return $members -} - - -#used by rename.test - theoretically should be on a separate interface! -dict set ::p::-1::_iface::o_methods CheckInvocants {arglist {args}} -proc ::p::-1::CheckInvocants {_ID_ args} { - #check all invocants in the _ID_ are consistent with data stored in their MAP variable - set status "ok" ;#default to optimistic assumption - set problems [list] - - set invocant_dict [dict get $_ID_ i] - set invocant_roles [dict keys $invocant_dict] - - foreach role $invocant_roles { - set invocant_list [dict get $invocant_dict $role] - foreach aliased_invocantdata $invocant_list { - set OID [lindex $aliased_invocantdata 0] - set map_invocantdata [dict get [set ::p::${OID}::_meta::map] invocantdata] - #we use lrange to make sure the lists are in canonical form - if {[lrange $map_invocantdata 0 end] ne [lrange $aliased_invocantdata 0 end]} { - set status "not-ok" - lappend problems [list type "invocant_data_mismatch" invocant_role $role oid $OID command_invocantdata $aliased_invocantdata map_invocantdata $map_invocantdata] - } - } - - } - - - set result [dict create] - dict set result status $status - dict set result problems $problems - - return $result -} - - -#get or set t -dict set ::p::-1::_iface::o_methods Namespace {arglist {args}} -proc ::p::-1::Namespace {_ID_ args} { - #set invocants [dict get $_ID_ i] - #set this_invocant [lindex [dict get $invocants this] 0] - #lassign $this_invocant OID this_info - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - set IID [lindex [dict get $MAP interfaces level0] end] - - namespace upvar ::p::${IID}::_iface o_varspace active_varspace - - if {[string length $active_varspace]} { - set ns ::p::${OID}::$active_varspace - } else { - set ns ::p::${OID} - } - - #!todo - review.. 'eval' & 'code' subcommands make it too easy to violate the object? - # - should .. Namespace be usable at all from outside the object? - - - if {[llength $args]} { - #special case some of the namespace subcommands. - - #delete - if {[string match "d*" [lindex $args 0]]} { - error "Don't destroy an object's namespace like this. Use '>object .. Destroy' to remove an object." - } - #upvar,ensemble,which,code,origin,expor,import,forget - if {[string range [lindex $args 0] 0 1] in [list "up" "en" "wh" "co" "or" "ex" "im" "fo"]} { - return [namespace eval $ns [list namespace {*}$args]] - } - #current - if {[string match "cu*" [lindex $args 0]]} { - return $ns - } - - #children,eval,exists,inscope,parent,qualifiers,tail - return [namespace {*}[linsert $args 1 $ns]] - } else { - return $ns - } -} - - - - - - - - - - -dict set ::p::-1::_iface::o_methods PatternUnknown {arglist {args}} -proc ::p::-1::PatternUnknown {_ID_ args} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - set patterns [dict get $MAP interfaces level1] - set existing_IID [lindex $patterns end] ;#!todo - choose 'open' interface to expand. - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $patterns $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level1 [concat [lreplace $patterns $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 1} [concat [lreplace $patterns $posn $posn] $IID] - #::p::predator::remap $invocant - } - - set handlermethod [lindex $args 0] - - - if {[llength $args]} { - set ::p::${IID}::_iface::o_unknown $handlermethod - return - } else { - set ::p::${IID}::_iface::o_unknown $handlermethod - } - -} - - - -dict set ::p::-1::_iface::o_methods Unknown {arglist {args}} -proc ::p::-1::Unknown {_ID_ args} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - - set interfaces [dict get $MAP interfaces level0] - set existing_IID [lindex $interfaces end] ;#!todo - choose 'open' interface to expand. - - set prev_open [set ::p::${existing_IID}::_iface::o_open] - - if {$existing_IID != [set IID [::p::internals::expand_interface $existing_IID]]} { - #remove ourself from the usedby list of the previous interface - array unset ::p::${existing_IID}::_iface::o_usedby i$OID - set ::p::${IID}::_iface::o_usedby(i$OID) $cmd - - set posn [lsearch $interfaces $existing_IID] - - set extracted_sub_dict [dict get $MAP interfaces] - dict set extracted_sub_dict level0 [concat [lreplace $interfaces $posn $posn] $IID] - dict set MAP interfaces $extracted_sub_dict - #lset map {1 0} [concat [lreplace $interfaces $posn $posn] $IID] - - set ::p::${IID}::_iface::o_open 0 - } else { - set ::p::${IID}::_iface::o_open $prev_open - } - - set handlermethod [lindex $args 0] - - if {[llength $args]} { - set ::p::${IID}::_iface::o_unknown $handlermethod - #set ::p::${IID}::(unknown) $handlermethod - - - #interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${OID}::$handlermethod - interp alias {} ::p::${IID}::_iface::(UNKNOWN) {} ::p::${IID}::_iface::$handlermethod - interp alias {} ::p::${OID}::(UNKNOWN) {} ::p::${OID}::$handlermethod - - #namespace eval ::p::${IID}::_iface [list namespace unknown $handlermethod] - #namespace eval ::p::${OID} [list namespace unknown $handlermethod] - - return - } else { - set ::p::${IID}::_iface::o_unknown $handlermethod - } - -} - - -#useful on commandline - can just uparrow and add to it to become ' .. As varname' instead of editing start and end of commandline to make it 'set varname []' -# should also work for non-object results -dict set ::p::-1::_iface::o_methods As {arglist {varname}} -proc ::p::-1::As {_ID_ varname} { - set invocants [dict get $_ID_ i] - #puts stdout "invocants: $invocants" - #!todo - handle multiple invocants with other roles, not just 'this' - - set OID [lindex [dict get $_ID_ i this] 0 0] - if {$OID ne "null"} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - tailcall set $varname $cmd - } else { - #puts stdout "info level 1 [info level 1]" - set role_members [dict get $_ID_ i this] - if {[llength $role_members] == 1} { - set member [lindex $role_members 0] - lassign $member _OID namespace default_method stackvalue _wrapped - tailcall set $varname $stackvalue - } else { - #multiple invocants - return all results as a list - set resultlist [list] - foreach member $role_members { - lassign $member _OID namespace default_method stackvalue _wrapped - lappend resultlist $stackvalue - } - tailcall set $varname $resultlist - } - } -} - -#!todo - AsFileStream ?? -dict set ::p::-1::_iface::o_methods AsFile {arglist {filename args}} -proc ::p::-1::AsFile {_ID_ filename args} { - dict set default -force 0 - dict set default -dumpmethod ".. Digest -algorithm raw" ;#how to serialize/persist an object - set opts [dict merge $default $args] - set force [dict get $opts -force] - set dumpmethod [dict get $opts -dumpmethod] - - - if {[file pathtype $filename] eq "relative"} { - set filename [pwd]/$filename - } - set filedir [file dirname $filename] - if {![sf::file_writable $filedir]} { - error "(method AsFile) ERROR folder $filedir is not writable" - } - if {[file exists $filename]} { - if {!$force} { - error "(method AsFile) ERROR file $filename already exists. Use -force 1 to overwrite" - } - if {![sf::file_writable $filename]} { - error "(method AsFile) ERROR file $filename is not writable - check permissions" - } - } - set fd [open $filename w] - fconfigure $fd -translation binary - - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $_ID_ i this] 0 0] - if {$OID ne "null"} { - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - #tailcall set $varname $cmd - set object_data [$cmd {*}$dumpmethod] - puts -nonewline $fd $object_data - close $fd - return [list status 1 bytes [string length $object_data] filename $filename] - } else { - #puts stdout "info level 1 [info level 1]" - set role_members [dict get $_ID_ i this] - if {[llength $role_members] == 1} { - set member [lindex $role_members 0] - lassign $member _OID namespace default_method stackvalue _wrapped - puts -nonewline $fd $stackvalue - close $fd - #tailcall set $varname $stackvalue - return [list status 1 bytes [string length $stackvalue] filename $filename] - } else { - #multiple invocants - return all results as a list - set resultlist [list] - foreach member $role_members { - lassign $member _OID namespace default_method stackvalue _wrapped - lappend resultlist $stackvalue - } - puts -nonewline $fd $resultset - close $fd - return [list status 1 bytes [string length $resultset] filename $filename] - #tailcall set $varname $resultlist - } - } - -} - - - -dict set ::p::-1::_iface::o_methods Object {arglist {}} -proc ::p::-1::Object {_ID_} { - set invocants [dict get $_ID_ i] - set OID [lindex [dict get $invocants this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - set result [string map [list ::> ::] $cmd] - if {![catch {info level -1} prev_level]} { - set called_by "(called by: $prev_level)" - } else { - set called_by "(called by: interp?)" - - } - - puts stdout "\n\nWARNING: '.. Object' calls are now obsolete. Please adjust your code. $called_by ( [info level 1])\n\n" - puts stdout " (returning $result)" - - return $result -} - -#todo: make equivalent to >pattern = cmdname, >pattern . x = cmdname , >pattern # apiname = cmdname -dict set ::p::-1::_iface::o_methods MakeAlias {arglist {cmdname}} -proc ::p::-1::MakeAlias {_ID_cmdname } { - set OID [::p::obj_get_this_oid $_ID_] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias itemCmd cmd - - error "concept probably won't work - try making dispatcher understand trailing '= cmdname' " -} -dict set ::p::-1::_iface::o_methods ID {arglist {}} -proc ::p::-1::ID {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - return $OID -} - -dict set ::p::-1::_iface::o_methods IFINFO {arglist {}} -proc ::p::-1::IFINFO {_ID_} { - puts stderr "--_ID_: $_ID_--" - set OID [::p::obj_get_this_oid $_ID_] - upvar #0 ::p::${OID}::_meta::map MAP - - puts stderr "-- MAP: $MAP--" - - set interfaces [dict get $MAP interfaces level0] - set IFID [lindex $interfaces 0] - - if {![llength $interfaces]} { - puts stderr "No interfaces present at level 0" - } else { - foreach IFID $interfaces { - set iface ::p::ifaces::>$IFID - puts stderr "$iface : [$iface --]" - puts stderr "\tis open: [set ::p::${IFID}::_iface::o_open]" - set variables [set ::p::${IFID}::_iface::o_variables] - puts stderr "\tvariables: $variables" - } - } - -} - - - - -dict set ::p::-1::_iface::o_methods INVOCANTDATA {arglist {}} -proc ::p::-1::INVOCANTDATA {_ID_} { - #same as a call to: >object .. - return $_ID_ -} - -#obsolete? -dict set ::p::-1::_iface::o_methods UPDATEDINVOCANTDATA {arglist {}} -proc ::p::-1::UPDATEDINVOCANTDATA {_ID_} { - set updated_ID_ $_ID_ - array set updated_roles [list] - - set invocants [dict get $_ID_ i] - set invocant_roles [dict keys $invocants] - foreach role $invocant_roles { - - set role_members [dict get $invocants $role] - foreach member [dict get $invocants $role] { - #each member is a 2-element list consisting of the OID and a dictionary - #each member is a 5-element list - #set OID [lindex $member 0] - #set object_dict [lindex $member 1] - lassign $member OID alias itemcmd cmd wrapped - - set MAP [set ::p::${OID}::_meta::map] - #if {[dictutils::equal {apply {{key v1 v2} {expr {$v1 eq $v2}}}} $mapvalue [dict get $object_dict map]]} {} - - if {[dict get $MAP invocantdata] eq $member} - #same - nothing to do - - } else { - package require overtype - puts stderr "---------------------------------------------------------" - puts stderr "UPDATEDINVOCANTDATA WARNING: invocantdata in _ID_ not equal to invocantdata in _meta::map - returning updated version" - set col1 [string repeat " " [expr {[string length [dict get $MAP invocantdata]] + 2}]] - puts stderr "[overtype::left $col1 {_ID_ map value}]: $member" - puts stderr "[overtype::left $col1 ::p::${OID}::_meta::map]: [dict get $MAP invocantdata]" - puts stderr "---------------------------------------------------------" - #take _meta::map version - lappend updated_roles($role) [dict get $MAP invocantdata] - } - - } - - #overwrite changed roles only - foreach role [array names updated_roles] { - dict set updated_ID_ i $role [set updated_roles($role)] - } - - return $updated_ID_ -} - - - -dict set ::p::-1::_iface::o_methods INFO {arglist {}} -proc ::p::-1::INFO {_ID_} { - 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] - append result "\t\tOID: $OID\n" - if {$OID ne "null"} { - upvar #0 ::p::${OID}::_meta::map MAP - append result "\t\tmap:\n" - foreach key [dict keys $MAP] { - append result "\t\t\t$key\n" - append result "\t\t\t\t [dict get $MAP $key]\n" - append result "\t\t\t----\n" - } - lassign [dict get $MAP invocantdata] _OID namespace default_method cmd _wrapped - append result "\t\tNamespace: $namespace\n" - append result "\t\tDefault method: $default_method\n" - append result "\t\tCommand: $cmd\n" - append result "\t\tCommand Alias: [::pattern::which_alias $cmd]\n" - append result "\t\tLevel0 interfaces: [dict get $MAP interfaces level0]\n" - append result "\t\tLevel1 interfaces: [dict get $MAP interfaces level1]\n" - } else { - lassign $member _OID namespace default_method stackvalue _wrapped - append result "\t\t last item on the predator stack is a value not an object" - append result "\t\t Value is: $stackvalue" - - } - } - append result "\n" - append result "\t-------------------------------\n" - } - - - - return $result -} - - - - -dict set ::p::-1::_iface::o_methods Rename {arglist {args}} -proc ::p::-1::Rename {_ID_ args} { - set OID [::p::obj_get_this_oid $_ID_] - if {![llength $args]} { - error "Rename expected \$newname argument" - } - - #Rename operates only on the 'this' invocant? What if there is more than one 'this'? should we raise an error if there is anything other than a single invocant? - upvar #0 ::p::${OID}::_meta::map MAP - - - - #puts ">>.>> Rename. _ID_: $_ID_" - - if {[catch { - - if {([llength $args] == 3) && [lindex $args 2] eq "rename"} { - - #appears to be a 'trace command rename' firing - #puts "\t>>>> rename trace fired $MAP $args <<<" - - lassign $args oldcmd newcmd - set extracted_invocantdata [dict get $MAP invocantdata] - lset extracted_invocantdata 3 $newcmd - dict set MAP invocantdata $extracted_invocantdata - - - lassign $extracted_invocantdata _oid alias _default_method object_command _wrapped - - #Write the same info into the _ID_ value of the alias - interp alias {} $alias {} ;#first we must delete it - interp alias {} $alias {} ::p::internals::predator [list i [list this [list $extracted_invocantdata ] ] context {}] - - - - #! $object_command was initially created as the renamed alias - so we have to do it again - uplevel 1 [list rename $alias $object_command] - trace add command $object_command rename [list $object_command .. Rename] - - } elseif {[llength $args] == 1} { - #let the rename trace fire and we will be called again to do the remap! - uplevel 1 [list rename [lindex [dict get $MAP invocantdata] 3] [lindex $args 0]] - } else { - error "Rename expected \$newname argument ." - } - - } errM]} { - puts stderr "\t@@@@@@ rename error" - set ruler "\t[string repeat - 80]" - puts stderr $ruler - puts stderr $errM - puts stderr $ruler - - } - - return - - -} - -proc ::p::obj_get_invocants {_ID_} { - return [dict get $_ID_ i] -} -#The invocant role 'this' is special and should always have only one member. -# dict get $_ID_ i XXX will always return a list of invocants that are playing role XXX -proc ::p::obj_get_this_oid {_ID_} { - return [lindex [dict get $_ID_ i this] 0 0] -} -proc ::p::obj_get_this_ns {_ID_} { - return [lindex [dict get $_ID_ i this] 0 1] -} - -proc ::p::obj_get_this_cmd {_ID_} { - return [lindex [dict get $_ID_ i this] 0 3] -} -proc ::p::obj_get_this_data {_ID_} { - lassign [dict get [set ::p::[lindex [dict get $_ID_ i this] 0 0]::_meta::map] invocantdata] OID ns _unknown cmd - #set this_invocant_data {*}[dict get $_ID_ i this] - return [list oid $OID ns $ns cmd $cmd] -} -proc ::p::map {OID varname} { - tailcall upvar #0 ::p::${OID}::_meta::map $varname -} - - - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/mime-1.7.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/mime-1.7.1.tm deleted file mode 100644 index b4b0d61d..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/mime-1.7.1.tm +++ /dev/null @@ -1,3934 +0,0 @@ -# mime.tcl - MIME body parts -# -# (c) 1999-2000 Marshall T. Rose -# (c) 2000 Brent Welch -# (c) 2000 Sandeep Tamhankar -# (c) 2000 Dan Kuchler -# (c) 2000-2001 Eric Melski -# (c) 2001 Jeff Hobbs -# (c) 2001-2008 Andreas Kupries -# (c) 2002-2003 David Welton -# (c) 2003-2008 Pat Thoyts -# (c) 2005 Benjamin Riefenstahl -# (c) 2013-2021 Poor Yorick -# -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's -# unpublished package of 1999. -# - -# new string features and inline scan are used, requiring 8.3. -package require Tcl 8.5 - -package provide mime 1.7.1 -package require tcl::chan::memchan - - -if {[catch {package require Trf 2.0}]} { - - # Fall-back to tcl-based procedures of base64 and quoted-printable - # encoders - ## - # Warning! - ## - # These are a fragile emulations of the more general calling - # sequence that appears to work with this code here. - ## - # The `__ignored__` arguments are expected to be `--` options on - # the caller's side. (See the uses in `copymessageaux`, - # `buildmessageaux`, `parsepart`, and `getbody`). - - package require base64 2.0 - set ::major [lindex [split [package require md5] .] 0] - - # Create these commands in the mime namespace so that they - # won't collide with things at the global namespace level - - namespace eval ::mime { - proc base64 {-mode what __ignored__ chunk} { - return [base64::$what $chunk] - } - proc quoted-printable {-mode what __ignored__ chunk} { - return [mime::qp_$what $chunk] - } - - if {$::major < 2} { - # md5 v1, result is hex string ready for use. - proc md5 {__ignored__ string} { - return [md5::md5 $string] - } - } else { - # md5 v2, need option to get hex string - proc md5 {__ignored__ string} { - return [md5::md5 -hex $string] - } - } - } - - unset ::major -} - -# -# state variables: -# -# canonicalP: input is in its canonical form -# content: type/subtype -# params: dictionary (keys are lower-case) -# encoding: transfer encoding -# version: MIME-version -# header: dictionary (keys are lower-case) -# lowerL: list of header keys, lower-case -# mixedL: list of header keys, mixed-case -# value: either "file", "parts", or "string" -# -# file: input file -# fd: cached file-descriptor, typically for root -# root: token for top-level part, for (distant) subordinates -# offset: number of octets from beginning of file/string -# count: length in octets of (encoded) content -# -# parts: list of bodies (tokens) -# -# string: input string -# -# cid: last child-id assigned -# - - -namespace eval ::mime { - variable mime - array set mime {uid 0 cid 0} - - # RFC 822 lexemes - variable addrtokenL - lappend addrtokenL \; , < > : . ( ) @ \" \[ ] \\ - variable addrlexemeL { - LX_SEMICOLON LX_COMMA - LX_LBRACKET LX_RBRACKET - LX_COLON LX_DOT - LX_LPAREN LX_RPAREN - LX_ATSIGN LX_QUOTE - LX_LSQUARE LX_RSQUARE - LX_QUOTE - } - - # RFC 2045 lexemes - variable typetokenL - lappend typetokenL \; , < > : ? ( ) @ \" \[ \] = / \\ - variable typelexemeL { - LX_SEMICOLON LX_COMMA - LX_LBRACKET LX_RBRACKET - LX_COLON LX_QUESTION - LX_LPAREN LX_RPAREN - LX_ATSIGN LX_QUOTE - LX_LSQUARE LX_RSQUARE - LX_EQUALS LX_SOLIDUS - LX_QUOTE - } - - variable encList { - ascii US-ASCII - big5 Big5 - cp1250 Windows-1250 - cp1251 Windows-1251 - cp1252 Windows-1252 - cp1253 Windows-1253 - cp1254 Windows-1254 - cp1255 Windows-1255 - cp1256 Windows-1256 - cp1257 Windows-1257 - cp1258 Windows-1258 - cp437 IBM437 - cp737 {} - cp775 IBM775 - cp850 IBM850 - cp852 IBM852 - cp855 IBM855 - cp857 IBM857 - cp860 IBM860 - cp861 IBM861 - cp862 IBM862 - cp863 IBM863 - cp864 IBM864 - cp865 IBM865 - cp866 IBM866 - cp869 IBM869 - cp874 {} - cp932 {} - cp936 GBK - cp949 {} - cp950 {} - dingbats {} - ebcdic {} - euc-cn EUC-CN - euc-jp EUC-JP - euc-kr EUC-KR - gb12345 GB12345 - gb1988 GB1988 - gb2312 GB2312 - iso2022 ISO-2022 - iso2022-jp ISO-2022-JP - iso2022-kr ISO-2022-KR - iso8859-1 ISO-8859-1 - iso8859-2 ISO-8859-2 - iso8859-3 ISO-8859-3 - iso8859-4 ISO-8859-4 - iso8859-5 ISO-8859-5 - iso8859-6 ISO-8859-6 - iso8859-7 ISO-8859-7 - iso8859-8 ISO-8859-8 - iso8859-9 ISO-8859-9 - iso8859-10 ISO-8859-10 - iso8859-13 ISO-8859-13 - iso8859-14 ISO-8859-14 - iso8859-15 ISO-8859-15 - iso8859-16 ISO-8859-16 - jis0201 JIS_X0201 - jis0208 JIS_C6226-1983 - jis0212 JIS_X0212-1990 - koi8-r KOI8-R - koi8-u KOI8-U - ksc5601 KS_C_5601-1987 - macCentEuro {} - macCroatian {} - macCyrillic {} - macDingbats {} - macGreek {} - macIceland {} - macJapan {} - macRoman {} - macRomania {} - macThai {} - macTurkish {} - macUkraine {} - shiftjis Shift_JIS - symbol {} - tis-620 TIS-620 - unicode {} - utf-8 UTF-8 - } - - variable encodings - array set encodings $encList - variable reversemap - # Initialized at the bottom of the file - - variable encAliasList { - ascii ANSI_X3.4-1968 - ascii iso-ir-6 - ascii ANSI_X3.4-1986 - ascii ISO_646.irv:1991 - ascii ASCII - ascii ISO646-US - ascii us - ascii IBM367 - ascii cp367 - cp437 cp437 - cp437 437 - cp775 cp775 - cp850 cp850 - cp850 850 - cp852 cp852 - cp852 852 - cp855 cp855 - cp855 855 - cp857 cp857 - cp857 857 - cp860 cp860 - cp860 860 - cp861 cp861 - cp861 861 - cp861 cp-is - cp862 cp862 - cp862 862 - cp863 cp863 - cp863 863 - cp864 cp864 - cp865 cp865 - cp865 865 - cp866 cp866 - cp866 866 - cp869 cp869 - cp869 869 - cp869 cp-gr - cp936 CP936 - cp936 MS936 - cp936 Windows-936 - iso8859-1 ISO_8859-1:1987 - iso8859-1 iso-ir-100 - iso8859-1 ISO_8859-1 - iso8859-1 latin1 - iso8859-1 l1 - iso8859-1 IBM819 - iso8859-1 CP819 - iso8859-2 ISO_8859-2:1987 - iso8859-2 iso-ir-101 - iso8859-2 ISO_8859-2 - iso8859-2 latin2 - iso8859-2 l2 - iso8859-3 ISO_8859-3:1988 - iso8859-3 iso-ir-109 - iso8859-3 ISO_8859-3 - iso8859-3 latin3 - iso8859-3 l3 - iso8859-4 ISO_8859-4:1988 - iso8859-4 iso-ir-110 - iso8859-4 ISO_8859-4 - iso8859-4 latin4 - iso8859-4 l4 - iso8859-5 ISO_8859-5:1988 - iso8859-5 iso-ir-144 - iso8859-5 ISO_8859-5 - iso8859-5 cyrillic - iso8859-6 ISO_8859-6:1987 - iso8859-6 iso-ir-127 - iso8859-6 ISO_8859-6 - iso8859-6 ECMA-114 - iso8859-6 ASMO-708 - iso8859-6 arabic - iso8859-7 ISO_8859-7:1987 - iso8859-7 iso-ir-126 - iso8859-7 ISO_8859-7 - iso8859-7 ELOT_928 - iso8859-7 ECMA-118 - iso8859-7 greek - iso8859-7 greek8 - iso8859-8 ISO_8859-8:1988 - iso8859-8 iso-ir-138 - iso8859-8 ISO_8859-8 - iso8859-8 hebrew - iso8859-9 ISO_8859-9:1989 - iso8859-9 iso-ir-148 - iso8859-9 ISO_8859-9 - iso8859-9 latin5 - iso8859-9 l5 - iso8859-10 iso-ir-157 - iso8859-10 l6 - iso8859-10 ISO_8859-10:1992 - iso8859-10 latin6 - iso8859-14 iso-ir-199 - iso8859-14 ISO_8859-14:1998 - iso8859-14 ISO_8859-14 - iso8859-14 latin8 - iso8859-14 iso-celtic - iso8859-14 l8 - iso8859-15 ISO_8859-15 - iso8859-15 Latin-9 - iso8859-16 iso-ir-226 - iso8859-16 ISO_8859-16:2001 - iso8859-16 ISO_8859-16 - iso8859-16 latin10 - iso8859-16 l10 - jis0201 X0201 - jis0208 iso-ir-87 - jis0208 x0208 - jis0208 JIS_X0208-1983 - jis0212 x0212 - jis0212 iso-ir-159 - ksc5601 iso-ir-149 - ksc5601 KS_C_5601-1989 - ksc5601 KSC5601 - ksc5601 korean - shiftjis MS_Kanji - utf-8 UTF8 - } - - namespace export {*}{ - copymessage finalize getbody getheader getproperty initialize - mapencoding parseaddress parsedatetime reversemapencoding setheader - uniqueID - } -} - -# ::mime::initialize -- -# -# Creates a MIME part, and returnes the MIME token for that part. -# -# Arguments: -# args Args can be any one of the following: -# ?-canonical type/subtype -# ?-param {key value}?... -# ?-encoding value? -# ?-header {key value}?... ? -# (-file name | -string value | -parts {token1 ... tokenN}) -# -# If the -canonical option is present, then the body is in -# canonical (raw) form and is found by consulting either the -file, -# -string, or -parts option. -# -# In addition, both the -param and -header options may occur zero -# or more times to specify "Content-Type" parameters (e.g., -# "charset") and header keyword/values (e.g., -# "Content-Disposition"), respectively. -# -# Also, -encoding, if present, specifies the -# "Content-Transfer-Encoding" when copying the body. -# -# If the -canonical option is not present, then the MIME part -# contained in either the -file or the -string option is parsed, -# dynamically generating subordinates as appropriate. -# -# Results: -# An initialized mime token. - -proc ::mime::initialize args { - global errorCode errorInfo - - variable mime - - set token [namespace current]::[incr mime(uid)] - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {[catch [list mime::initializeaux $token {*}$args] result eopts]} { - catch {mime::finalize $token -subordinates dynamic} - return -options $eopts $result - } - return $token -} - -# ::mime::initializeaux -- -# -# Configures the MIME token created in mime::initialize based on -# the arguments that mime::initialize supports. -# -# Arguments: -# token The MIME token to configure. -# args Args can be any one of the following: -# ?-canonical type/subtype -# ?-param {key value}?... -# ?-encoding value? -# ?-header {key value}?... ? -# (-file name | -string value | -parts {token1 ... tokenN}) -# -# Results: -# Either configures the mime token, or throws an error. - -proc ::mime::initializeaux {token args} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set params [set state(params) {}] - set state(encoding) {} - set state(version) 1.0 - - set state(header) {} - set state(lowerL) {} - set state(mixedL) {} - - set state(cid) 0 - - set userheader 0 - - set argc [llength $args] - for {set argx 0} {$argx < $argc} {incr argx} { - set option [lindex $args $argx] - if {[incr argx] >= $argc} { - error "missing argument to $option" - } - set value [lindex $args $argx] - - switch -- $option { - -canonical { - set state(content) [string tolower $value] - } - - -param { - if {[llength $value] != 2} { - error "-param expects a key and a value, not $value" - } - set lower [string tolower [set mixed [lindex $value 0]]] - if {[info exists params($lower)]} { - error "the $mixed parameter may be specified at most once" - } - - set params($lower) [lindex $value 1] - set state(params) [array get params] - } - - -encoding { - set value [string tolower $value[set value {}]] - - switch -- $value { - 7bit - 8bit - binary - quoted-printable - base64 { - } - - default { - error "unknown value for -encoding $state(encoding)" - } - } - set state(encoding) [string tolower $value] - } - - -header { - if {[llength $value] != 2} { - error "-header expects a key and a value, not $value" - } - set lower [string tolower [set mixed [lindex $value 0]]] - if {$lower eq {content-type}} { - error "use -canonical instead of -header $value" - } - if {$lower eq {content-transfer-encoding}} { - error "use -encoding instead of -header $value" - } - if {$lower in {content-md5 mime-version}} { - error {don't go there...} - } - if {$lower ni $state(lowerL)} { - lappend state(lowerL) $lower - lappend state(mixedL) $mixed - } - - set userheader 1 - - array set header $state(header) - lappend header($lower) [lindex $value 1] - set state(header) [array get header] - } - - -file { - set state(file) $value - } - - -parts { - set state(parts) $value - } - - -string { - set state(string) $value - - set state(lines) [split $value \n] - set state(lines.count) [llength $state(lines)] - set state(lines.current) 0 - } - - -root { - # the following are internal options - - set state(root) $value - } - - -offset { - set state(offset) $value - } - - -count { - set state(count) $value - } - - -lineslist { - set state(lines) $value - set state(lines.count) [llength $state(lines)] - set state(lines.current) 0 - #state(string) is needed, but will be built when required - set state(string) {} - } - - default { - error "unknown option $option" - } - } - } - - #We only want one of -file, -parts or -string: - set valueN 0 - foreach value {file parts string} { - if {[info exists state($value)]} { - set state(value) $value - incr valueN - } - } - if {$valueN != 1 && ![info exists state(lines)]} { - error {specify exactly one of -file, -parts, or -string} - } - - if {[set state(canonicalP) [info exists state(content)]]} { - switch -- $state(value) { - file { - set state(offset) 0 - } - - parts { - switch -glob -- $state(content) { - text/* - - - image/* - - - audio/* - - - video/* { - error "-canonical $state(content) and -parts do not mix" - } - - default { - if {$state(encoding) ne {}} { - error {-encoding and -parts do not mix} - } - } - } - } - default {# Go ahead} - } - - if {[lsearch -exact $state(lowerL) content-id] < 0} { - lappend state(lowerL) content-id - lappend state(mixedL) Content-ID - - array set header $state(header) - lappend header(content-id) [uniqueID] - set state(header) [array get header] - } - - set state(version) 1.0 - return - } - - if {$state(params) ne {}} { - error {-param requires -canonical} - } - if {$state(encoding) ne {}} { - error {-encoding requires -canonical} - } - if {$userheader} { - error {-header requires -canonical} - } - if {[info exists state(parts)]} { - error {-parts requires -canonical} - } - - if {[set fileP [info exists state(file)]]} { - if {[set openP [info exists state(root)]]} { - # FRINK: nocheck - variable $state(root) - upvar 0 $state(root) root - - set state(fd) $root(fd) - } else { - set state(root) $token - set state(fd) [open $state(file) RDONLY] - set state(offset) 0 - seek $state(fd) 0 end - set state(count) [tell $state(fd)] - - fconfigure $state(fd) -translation binary - } - } - - set code [catch {mime::parsepart $token} result] - set ecode $errorCode - set einfo $errorInfo - - if {$fileP} { - if {!$openP} { - unset state(root) - catch {close $state(fd)} - } - unset state(fd) - } - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::mime::parsepart -- -# -# Parses the MIME headers and attempts to break up the message -# into its various parts, creating a MIME token for each part. -# -# Arguments: -# token The MIME token to parse. -# -# Results: -# Throws an error if it has problems parsing the MIME token, -# otherwise it just sets up the appropriate variables. - -proc ::mime::parsepart {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {[set fileP [info exists state(file)]]} { - seek $state(fd) [set pos $state(offset)] start - set last [expr {$state(offset) + $state(count) - 1}] - } else { - set string $state(string) - } - - set vline {} - while 1 { - set blankP 0 - if {$fileP} { - if {($pos > $last) || ([set x [gets $state(fd) line]] <= 0)} { - set blankP 1 - } else { - incr pos [expr {$x + 1}] - } - } else { - if {$state(lines.current) >= $state(lines.count)} { - set blankP 1 - set line {} - } else { - set line [lindex $state(lines) $state(lines.current)] - incr state(lines.current) - set x [string length $line] - if {$x == 0} {set blankP 1} - } - } - - if {!$blankP && [string match *\r $line]} { - set line [string range $line 0 $x-2] - if {$x == 1} { - set blankP 1 - } - } - - if {!$blankP && ( - [string first { } $line] == 0 - || - [string first \t $line] == 0 - )} { - append vline \n $line - continue - } - - if {$vline eq {}} { - if {$blankP} { - break - } - - set vline $line - continue - } - - if { - [set x [string first : $vline]] <= 0 - || - [set mixed [string trimright [ - string range $vline 0 [expr {$x - 1}]]]] eq {} - } { - error "improper line in header: $vline" - } - set value [string trim [string range $vline [expr {$x + 1}] end]] - switch -- [set lower [string tolower $mixed]] { - content-type { - if {[info exists state(content)]} { - error "multiple Content-Type fields starting with $vline" - } - - if {![catch {set x [parsetype $token $value]}]} { - set state(content) [lindex $x 0] - set state(params) [lindex $x 1] - } - } - - content-md5 { - } - - content-transfer-encoding { - if { - $state(encoding) ne {} - && - $state(encoding) ne [string tolower $value] - } { - error "multiple Content-Transfer-Encoding fields starting with $vline" - } - - set state(encoding) [string tolower $value] - } - - mime-version { - set state(version) $value - } - - default { - if {[lsearch -exact $state(lowerL) $lower] < 0} { - lappend state(lowerL) $lower - lappend state(mixedL) $mixed - } - - array set header $state(header) - lappend header($lower) $value - set state(header) [array get header] - } - } - - if {$blankP} { - break - } - set vline $line - } - - if {![info exists state(content)]} { - set state(content) text/plain - set state(params) [list charset us-ascii] - } - - if {![string match multipart/* $state(content)]} { - if {$fileP} { - set x [tell $state(fd)] - incr state(count) [expr {$state(offset) - $x}] - set state(offset) $x - } else { - # rebuild string, this is cheap and needed by other functions - set state(string) [join [ - lrange $state(lines) $state(lines.current) end] \n] - } - - if {[string match message/* $state(content)]} { - # FRINK: nocheck - variable [set child $token-[incr state(cid)]] - - set state(value) parts - set state(parts) $child - if {$fileP} { - mime::initializeaux $child \ - -file $state(file) -root $state(root) \ - -offset $state(offset) -count $state(count) - } else { - if {[info exists state(encoding)]} { - set strng [join [ - lrange $state(lines) $state(lines.current) end] \n] - switch -- $state(encoding) { - base64 - - quoted-printable { - set strng [$state(encoding) -mode decode -- $strng] - } - default {} - } - mime::initializeaux $child -string $strng - } else { - mime::initializeaux $child -lineslist [ - lrange $state(lines) $state(lines.current) end] - } - } - } - - return - } - - set state(value) parts - - set boundary {} - foreach {k v} $state(params) { - if {$k eq {boundary}} { - set boundary $v - break - } - } - if {$boundary eq {}} { - error "boundary parameter is missing in $state(content)" - } - if {[string trim $boundary] eq {}} { - error "boundary parameter is empty in $state(content)" - } - - if {$fileP} { - set pos [tell $state(fd)] - # This variable is like 'start', for the reasons laid out - # below, in the other branch of this conditional. - set initialpos $pos - } else { - # This variable is like 'start', a list of lines in the - # part. This record is made even before we find a starting - # boundary and used if we run into the terminating boundary - # before a starting boundary was found. In that case the lines - # before the terminator as recorded by tracelines are seen as - # the part, or at least we attempt to parse them as a - # part. See the forceoctet and nochild flags later. We cannot - # use 'start' as that records lines only after the starting - # boundary was found. - set tracelines [list] - } - - set inP 0 - set moreP 1 - set forceoctet 0 - while {$moreP} { - if {$fileP} { - if {$pos > $last} { - # We have run over the end of the part per the outer - # information without finding a terminating boundary. - # We now fake the boundary and force the parser to - # give any new part coming of this a mime-type of - # application/octet-stream regardless of header - # information. - set line "--$boundary--" - set x [string length $line] - set forceoctet 1 - } else { - if {[set x [gets $state(fd) line]] < 0} { - error "end-of-file encountered while parsing $state(content)" - } - } - incr pos [expr {$x + 1}] - } else { - if {$state(lines.current) >= $state(lines.count)} { - error "end-of-string encountered while parsing $state(content)" - } else { - set line [lindex $state(lines) $state(lines.current)] - incr state(lines.current) - set x [string length $line] - } - set x [string length $line] - } - if {[string last \r $line] == $x - 1} { - set line [string range $line 0 [expr {$x - 2}]] - set crlf 2 - } else { - set crlf 1 - } - - if {[string first --$boundary $line] != 0} { - if {$inP && !$fileP} { - lappend start $line - } - continue - } else { - lappend tracelines $line - } - - if {!$inP} { - # Haven't seen the starting boundary yet. Check if the - # current line contains this starting boundary. - - if {$line eq "--$boundary"} { - # Yes. Switch parser state to now search for the - # terminating boundary of the part and record where - # the part begins (or initialize the recorder for the - # lines in the part). - set inP 1 - if {$fileP} { - set start $pos - } else { - set start [list] - } - continue - } elseif {$line eq "--$boundary--"} { - # We just saw a terminating boundary before we ever - # saw the starting boundary of a part. This forces us - # to stop parsing, we do this by forcing the parser - # into an accepting state. We will try to create a - # child part based on faked start position or recorded - # lines, or, if that fails, let the current part have - # no children. - - # As an example note the test case mime-3.7 and the - # referenced file "badmail1.txt". - - set inP 1 - if {$fileP} { - set start $initialpos - } else { - set start $tracelines - } - set forceoctet 1 - # Fall through. This brings to the creation of the new - # part instead of searching further and possible - # running over the end. - } else { - continue - } - } - - # Looking for the end of the current part. We accept both a - # terminating boundary and the starting boundary of the next - # part as the end of the current part. - - if {[set moreP [string compare $line --$boundary--]] - && $line ne "--$boundary"} { - - # The current part has not ended, so we record the line - # if we are inside a part and doing string parsing. - if {$inP && !$fileP} { - lappend start $line - } - continue - } - - # The current part has ended. We now determine the exact - # boundaries, create a mime part object for it and recursively - # parse it deeper as part of that action. - - # FRINK: nocheck - variable [set child $token-[incr state(cid)]] - - lappend state(parts) $child - - set nochild 0 - if {$fileP} { - if {[set count [expr {$pos - ($start + $x + $crlf + 1)}]] < 0} { - set count 0 - } - if {$forceoctet} { - set ::errorInfo {} - if {[catch { - mime::initializeaux $child \ - -file $state(file) -root $state(root) \ - -offset $start -count $count - }]} { - set nochild 1 - set state(parts) [lrange $state(parts) 0 end-1] - } } else { - mime::initializeaux $child \ - -file $state(file) -root $state(root) \ - -offset $start -count $count - } - seek $state(fd) [set start $pos] start - } else { - if {$forceoctet} { - if {[catch { - mime::initializeaux $child -lineslist $start - }]} { - set nochild 1 - set state(parts) [lrange $state(parts) 0 end-1] - } - } else { - mime::initializeaux $child -lineslist $start - } - set start {} - } - if {$forceoctet && !$nochild} { - variable $child - upvar 0 $child childstate - set childstate(content) application/octet-stream - } - set forceoctet 0 - } -} - -# ::mime::parsetype -- -# -# Parses the string passed in and identifies the content-type and -# params strings. -# -# Arguments: -# token The MIME token to parse. -# string The content-type string that should be parsed. -# -# Results: -# Returns the content and params for the string as a two element -# tcl list. - -proc ::mime::parsetype {token string} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - variable typetokenL - variable typelexemeL - - set state(input) $string - set state(buffer) {} - set state(lastC) LX_END - set state(comment) {} - set state(tokenL) $typetokenL - set state(lexemeL) $typelexemeL - - set code [catch {mime::parsetypeaux $token $string} result] - set ecode $errorCode - set einfo $errorInfo - - unset {*}{ - state(input) - state(buffer) - state(lastC) - state(comment) - state(tokenL) - state(lexemeL) - } - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::mime::parsetypeaux -- -# -# A helper function for mime::parsetype. Parses the specified -# string looking for the content type and params. -# -# Arguments: -# token The MIME token to parse. -# string The content-type string that should be parsed. -# -# Results: -# Returns the content and params for the string as a two element -# tcl list. - -proc ::mime::parsetypeaux {token string} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {[parselexeme $token] ne {LX_ATOM}} { - error [format {expecting type (found %s)} $state(buffer)] - } - set type [string tolower $state(buffer)] - - switch -- [parselexeme $token] { - LX_SOLIDUS { - } - - LX_END { - if {$type ne {message}} { - error "expecting type/subtype (found $type)" - } - - return [list message/rfc822 {}] - } - - default { - error [format "expecting \"/\" (found %s)" $state(buffer)] - } - } - - if {[parselexeme $token] ne {LX_ATOM}} { - error [format "expecting subtype (found %s)" $state(buffer)] - } - append type [string tolower /$state(buffer)] - - array set params {} - while 1 { - switch -- [parselexeme $token] { - LX_END { - return [list $type [array get params]] - } - - LX_SEMICOLON { - } - - default { - error [format "expecting \";\" (found %s)" $state(buffer)] - } - } - - switch -- [parselexeme $token] { - LX_END { - return [list $type [array get params]] - } - - LX_ATOM { - } - - default { - error [format "expecting attribute (found %s)" $state(buffer)] - } - } - - set attribute [string tolower $state(buffer)] - - if {[parselexeme $token] ne {LX_EQUALS}} { - error [format {expecting "=" (found %s)} $state(buffer)] - } - - switch -- [parselexeme $token] { - LX_ATOM { - } - - LX_QSTRING { - set state(buffer) [ - string range $state(buffer) 1 [ - expr {[string length $state(buffer)] - 2}]] - } - - default { - error [format {expecting value (found %s)} $state(buffer)] - } - } - set params($attribute) $state(buffer) - } -} - -# ::mime::finalize -- -# -# mime::finalize destroys a MIME part. -# -# If the -subordinates option is present, it specifies which -# subordinates should also be destroyed. The default value is -# "dynamic". -# -# Arguments: -# token The MIME token to parse. -# args Args can be optionally be of the following form: -# ?-subordinates "all" | "dynamic" | "none"? -# -# Results: -# Returns an empty string. - -proc ::mime::finalize {token args} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set options [list -subordinates dynamic] - array set options $args - - switch -- $options(-subordinates) { - all { - #TODO: this code path is untested - if {$state(value) eq {parts}} { - foreach part $state(parts) { - eval [linsert $args 0 mime::finalize $part] - } - } - } - - dynamic { - for {set cid $state(cid)} {$cid > 0} {incr cid -1} { - eval [linsert $args 0 mime::finalize $token-$cid] - } - } - - none { - } - - default { - error "unknown value for -subordinates $options(-subordinates)" - } - } - - foreach name [array names state] { - unset state($name) - } - # FRINK: nocheck - unset $token -} - -# ::mime::getproperty -- -# -# mime::getproperty returns the properties of a MIME part. -# -# The properties are: -# -# property value -# ======== ===== -# content the type/subtype describing the content -# encoding the "Content-Transfer-Encoding" -# params a list of "Content-Type" parameters -# parts a list of tokens for the part's subordinates -# size the approximate size of the content (unencoded) -# -# The "parts" property is present only if the MIME part has -# subordinates. -# -# If mime::getproperty is invoked with the name of a specific -# property, then the corresponding value is returned; instead, if -# -names is specified, a list of all properties is returned; -# otherwise, a dictionary of properties is returned. -# -# Arguments: -# token The MIME token to parse. -# property One of 'content', 'encoding', 'params', 'parts', and -# 'size'. Defaults to returning a dictionary of -# properties. -# -# Results: -# Returns the properties of a MIME part - -proc ::mime::getproperty {token {property {}}} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - switch -- $property { - {} { - array set properties [list content $state(content) \ - encoding $state(encoding) \ - params $state(params) \ - size [getsize $token]] - if {[info exists state(parts)]} { - set properties(parts) $state(parts) - } - - return [array get properties] - } - - -names { - set names [list content encoding params] - if {[info exists state(parts)]} { - lappend names parts - } - - return $names - } - - content - - - encoding - - - params { - return $state($property) - } - - parts { - if {![info exists state(parts)]} { - error {MIME part is a leaf} - } - - return $state(parts) - } - - size { - return [getsize $token] - } - - default { - error "unknown property $property" - } - } -} - -# ::mime::getsize -- -# -# Determine the size (in bytes) of a MIME part/token -# -# Arguments: -# token The MIME token to parse. -# -# Results: -# Returns the size in bytes of the MIME token. - -proc ::mime::getsize {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - switch -- $state(value)/$state(canonicalP) { - file/0 { - set size $state(count) - } - - file/1 { - return [file size $state(file)] - } - - parts/0 - - - parts/1 { - set size 0 - foreach part $state(parts) { - incr size [getsize $part] - } - - return $size - } - - string/0 { - set size [string length $state(string)] - } - - string/1 { - return [string length $state(string)] - } - default { - error "Unknown combination \"$state(value)/$state(canonicalP)\"" - } - } - - if {$state(encoding) eq {base64}} { - set size [expr {($size * 3 + 2) / 4}] - } - - return $size -} - - -proc ::mime::getContentType token { - variable $token - upvar 0 $token state - set res $state(content) - - set boundary {} - foreach {k v} $state(params) { - if {$k eq {boundary}} { - set boundary $v - } - append res ";\n $k=\"$v\"" - } - - # Save boundary separate from the params - set state(boundary) $boundary - - if {([string match multipart/* $state(content)]) \ - && ($boundary eq {})} { - # we're doing everything in one pass... - set key [clock seconds]$token[info hostname][array get state] - set seqno 8 - while {[incr seqno -1] >= 0} { - set key [md5 -- $key] - } - set boundary "----- =_[string trim [base64 -mode encode -- $key]]" - - set state(boundary) $boundary - - append res ";\n boundary=\"$boundary\"" - } - return $res -} - -# ::mime::getheader -- -# -# mime::getheader returns the header of a MIME part. -# -# A header consists of zero or more key/value pairs. Each value is a -# list containing one or more strings. -# -# If mime::getheader is invoked with the name of a specific key, then -# a list containing the corresponding value(s) is returned; instead, -# if -names is specified, a list of all keys is returned; otherwise, a -# dictionary is returned. Note that when a -# key is specified (e.g., "Subject"), the list returned usually -# contains exactly one string; however, some keys (e.g., "Received") -# often occur more than once in the header, accordingly the list -# returned usually contains more than one string. -# -# Arguments: -# token The MIME token to parse. -# key Either a key or '-names'. If it is '-names' a list -# of all keys is returned. -# -# Results: -# Returns the header of a MIME part. - -proc ::mime::getheader {token {key {}}} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set header $state(header) - switch -- $key { - {} { - set result {} - lappend result MIME-Version $state(version) - foreach lower $state(lowerL) mixed $state(mixedL) { - foreach value $header($lower) { - lappend result $mixed $value - } - } - set tencoding [getTransferEncoding $token] - if {$tencoding ne {}} { - lappend result Content-Transfer-Encoding $tencoding - } - lappend result Content-Type [getContentType $token] - return $result - } - - -names { - return $state(mixedL) - } - - default { - set lower [string tolower $key] - - switch $lower { - content-transfer-encoding { - return [getTransferEncoding $token] - } - content-type { - return [list [getContentType $token]] - } - mime-version { - return [list $state(version)] - } - default { - if {![info exists header($lower)]} { - error "key $key not in header" - } - return $header($lower) - } - } - } - } -} - - -proc ::mime::getTransferEncoding token { - variable $token - upvar 0 $token state - set res {} - if {[set encoding $state(encoding)] eq {}} { - set encoding [encoding $token] - } - if {$encoding ne {}} { - set res $encoding - } - switch -- $encoding { - base64 - - - quoted-printable { - set converter $encoding - } - 7bit - 8bit - binary - {} { - # Bugfix for [#477088], also [#539952] - # Go ahead - } - default { - error "Can't handle content encoding \"$encoding\"" - } - } - return $res -} - -# ::mime::setheader -- -# -# mime::setheader writes, appends to, or deletes the value associated -# with a key in the header. -# -# The value for -mode is one of: -# -# write: the key/value is either created or overwritten (the -# default); -# -# append: a new value is appended for the key (creating it as -# necessary); or, -# -# delete: all values associated with the key are removed (the -# "value" parameter is ignored). -# -# Regardless, mime::setheader returns the previous value associated -# with the key. -# -# Arguments: -# token The MIME token to parse. -# key The name of the key whose value should be set. -# value The value for the header key to be set to. -# args An optional argument of the form: -# ?-mode "write" | "append" | "delete"? -# -# Results: -# Returns previous value associated with the specified key. - -proc ::mime::setheader {token key value args} { - # FRINK: nocheck - variable internal - variable $token - upvar 0 $token state - - array set options [list -mode write] - array set options $args - - set lower [string tolower $key] - array set header $state(header) - if {[set x [lsearch -exact $state(lowerL) $lower]] < 0} { - #TODO: this code path is not tested - if {$options(-mode) eq {delete}} { - error "key $key not in header" - } - - lappend state(lowerL) $lower - lappend state(mixedL) $key - - set result {} - } else { - set result $header($lower) - } - switch -- $options(-mode) { - append - write { - if {!$internal} { - switch -- $lower { - content-md5 - - - content-type - - - content-transfer-encoding - - - mime-version { - set values [getheader $token $lower] - if {$value ni $values} { - error "key $key may not be set" - } - } - default {# Skip key} - } - } - switch -- $options(-mode) { - append { - lappend header($lower) $value - } - write { - set header($lower) [list $value] - } - } - } - delete { - unset header($lower) - set state(lowerL) [lreplace $state(lowerL) $x $x] - set state(mixedL) [lreplace $state(mixedL) $x $x] - } - - default { - error "unknown value for -mode $options(-mode)" - } - } - - set state(header) [array get header] - return $result -} - -# ::mime::getbody -- -# -# mime::getbody returns the body of a leaf MIME part in canonical form. -# -# If the -command option is present, then it is repeatedly invoked -# with a fragment of the body as this: -# -# uplevel #0 $callback [list "data" $fragment] -# -# (The -blocksize option, if present, specifies the maximum size of -# each fragment passed to the callback.) -# When the end of the body is reached, the callback is invoked as: -# -# uplevel #0 $callback "end" -# -# Alternatively, if an error occurs, the callback is invoked as: -# -# uplevel #0 $callback [list "error" reason] -# -# Regardless, the return value of the final invocation of the callback -# is propagated upwards by mime::getbody. -# -# If the -command option is absent, then the return value of -# mime::getbody is a string containing the MIME part's entire body. -# -# Arguments: -# token The MIME token to parse. -# args Optional arguments of the form: -# ?-decode? ?-command callback ?-blocksize octets? ? -# -# Results: -# Returns a string containing the MIME part's entire body, or -# if '-command' is specified, the return value of the command -# is returned. - -proc ::mime::getbody {token args} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - set decode 0 - if {[set pos [lsearch -exact $args -decode]] >= 0} { - set decode 1 - set args [lreplace $args $pos $pos] - } - - array set options [list -command [ - list mime::getbodyaux $token] -blocksize 4096] - array set options $args - if {$options(-blocksize) < 1} { - error "-blocksize expects a positive integer, not $options(-blocksize)" - } - - set code 0 - set ecode {} - set einfo {} - - switch -- $state(value)/$state(canonicalP) { - file/0 { - set fd [open $state(file) RDONLY] - - set code [catch { - fconfigure $fd -translation binary - seek $fd [set pos $state(offset)] start - set last [expr {$state(offset) + $state(count) - 1}] - - set fragment {} - while {$pos <= $last} { - if {[set cc [ - expr {($last - $pos) + 1}]] > $options(-blocksize)} { - set cc $options(-blocksize) - } - incr pos [set len [ - string length [set chunk [read $fd $cc]]]] - switch -exact -- $state(encoding) { - base64 - - - quoted-printable { - if {([set x [string last \n $chunk]] > 0) \ - && ($x + 1 != $len)} { - set chunk [string range $chunk 0 $x] - seek $fd [incr pos [expr {($x + 1) - $len}]] start - } - set chunk [ - $state(encoding) -mode decode -- $chunk] - } - 7bit - 8bit - binary - {} { - # Bugfix for [#477088] - # Go ahead, leave chunk alone - } - default { - error "Can't handle content encoding \"$state(encoding)\"" - } - } - append fragment $chunk - - set cc [expr {$options(-blocksize) - 1}] - while {[string length $fragment] > $options(-blocksize)} { - uplevel #0 $options(-command) [ - list data [string range $fragment 0 $cc]] - - set fragment [ - string range $fragment $options(-blocksize) end] - } - } - if {[string length $fragment] > 0} { - uplevel #0 $options(-command) [list data $fragment] - } - } result] - set ecode $errorCode - set einfo $errorInfo - - catch {close $fd} - } - - file/1 { - set fd [open $state(file) RDONLY] - - set code [catch { - fconfigure $fd -translation binary - - while {[string length [ - set fragment [read $fd $options(-blocksize)]]] > 0} { - uplevel #0 $options(-command) [list data $fragment] - } - } result] - set ecode $errorCode - set einfo $errorInfo - - catch {close $fd} - } - - parts/0 - - - parts/1 { - error {MIME part isn't a leaf} - } - - string/0 - - - string/1 { - switch -- $state(encoding)/$state(canonicalP) { - base64/0 - - - quoted-printable/0 { - set fragment [ - $state(encoding) -mode decode -- $state(string)] - } - - default { - # Not a bugfix for [#477088], but clarification - # This handles no-encoding, 7bit, 8bit, and binary. - set fragment $state(string) - } - } - - set code [catch { - set cc [expr {$options(-blocksize) -1}] - while {[string length $fragment] > $options(-blocksize)} { - uplevel #0 $options(-command) [ - list data [string range $fragment 0 $cc]] - - set fragment [ - string range $fragment $options(-blocksize) end] - } - if {[string length $fragment] > 0} { - uplevel #0 $options(-command) [list data $fragment] - } - } result] - set ecode $errorCode - set einfo $errorInfo - } - default { - error "Unknown combination \"$state(value)/$state(canonicalP)\"" - } - } - - set code [catch { - if {$code} { - uplevel #0 $options(-command) [list error $result] - } else { - uplevel #0 $options(-command) [list end] - } - } result] - set ecode $errorCode - set einfo $errorInfo - - if {$code} { - return -code $code -errorinfo $einfo -errorcode $ecode $result - } - - if {$decode} { - array set params [mime::getproperty $token params] - - if {[info exists params(charset)]} { - set charset $params(charset) - } else { - set charset US-ASCII - } - - set enc [reversemapencoding $charset] - if {$enc ne {}} { - set result [::encoding convertfrom $enc $result] - } else { - return -code error "-decode failed: can't reversemap charset $charset" - } - } - - return $result -} - -# ::mime::getbodyaux -- -# -# Builds up the body of the message, fragment by fragment. When -# the entire message has been retrieved, it is returned. -# -# Arguments: -# token The MIME token to parse. -# reason One of 'data', 'end', or 'error'. -# fragment The section of data data fragment to extract a -# string from. -# -# Results: -# Returns nothing, except when called with the 'end' argument -# in which case it returns a string that contains all of the -# data that 'getbodyaux' has been called with. Will throw an -# error if it is called with the reason of 'error'. - -proc ::mime::getbodyaux {token reason {fragment {}}} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - switch $reason { - data { - append state(getbody) $fragment - return {} - } - - end { - if {[info exists state(getbody)]} { - set result $state(getbody) - unset state(getbody) - } else { - set result {} - } - - return $result - } - - error { - catch {unset state(getbody)} - error $reason - } - - default { - error "Unknown reason \"$reason\"" - } - } -} - -# ::mime::copymessage -- -# -# mime::copymessage copies the MIME part to the specified channel. -# -# mime::copymessage operates synchronously, and uses fileevent to -# allow asynchronous operations to proceed independently. -# -# Arguments: -# token The MIME token to parse. -# channel The channel to copy the message to. -# -# Results: -# Returns nothing unless an error is thrown while the message -# is being written to the channel. - -proc ::mime::copymessage {token channel} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - set openP [info exists state(fd)] - - set code [catch {mime::copymessageaux $token $channel} result] - set ecode $errorCode - set einfo $errorInfo - - if {!$openP && [info exists state(fd)]} { - if {![info exists state(root)]} { - catch {close $state(fd)} - } - unset state(fd) - } - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::mime::copymessageaux -- -# -# mime::copymessageaux copies the MIME part to the specified channel. -# -# Arguments: -# token The MIME token to parse. -# channel The channel to copy the message to. -# -# Results: -# Returns nothing unless an error is thrown while the message -# is being written to the channel. - -proc ::mime::copymessageaux {token channel} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set header $state(header) - - set result {} - foreach {mixed value} [getheader $token] { - puts $channel "$mixed: $value" - } - - set boundary $state(boundary) ;# computed by `getheader` - - set converter {} - set encoding {} - if {$state(value) ne {parts}} { - if {$state(canonicalP)} { - if {[set encoding $state(encoding)] eq {}} { - set encoding [encoding $token] - } - if {$encoding ne {}} { - puts $channel "Content-Transfer-Encoding: $encoding" - } - switch -- $encoding { - base64 - - - quoted-printable { - set converter $encoding - } - 7bit - 8bit - binary - {} { - # Bugfix for [#477088], also [#539952] - # Go ahead - } - default { - error "Can't handle content encoding \"$encoding\"" - } - } - } - } - - if {[info exists state(error)]} { - unset state(error) - } - - switch -- $state(value) { - file { - set closeP 1 - if {[info exists state(root)]} { - # FRINK: nocheck - variable $state(root) - upvar 0 $state(root) root - - if {[info exists root(fd)]} { - set fd $root(fd) - set closeP 0 - } else { - set fd [set state(fd) [open $state(file) RDONLY]] - } - set size $state(count) - } else { - set fd [set state(fd) [open $state(file) RDONLY]] - # read until eof - set size -1 - } - seek $fd $state(offset) start - if {$closeP} { - fconfigure $fd -translation binary - } - - puts $channel {} - - while {$size != 0 && ![eof $fd]} { - if {$size < 0 || $size > 32766} { - set X [read $fd 32766] - } else { - set X [read $fd $size] - } - if {$size > 0} { - set size [expr {$size - [string length $X]}] - } - if {$converter eq {}} { - puts -nonewline $channel $X - } else { - puts -nonewline $channel [$converter -mode encode -- $X] - } - } - - if {$closeP} { - catch {close $state(fd)} - unset state(fd) - } - } - - parts { - if { - ![info exists state(root)] - && - [info exists state(file)] - } { - set state(fd) [open $state(file) RDONLY] - fconfigure $state(fd) -translation binary - } - - switch -glob -- $state(content) { - message/* { - puts $channel {} - foreach part $state(parts) { - mime::copymessage $part $channel - break - } - } - - default { - # Note RFC 2046: See buildmessageaux for details. - # - # The boundary delimiter MUST occur at the - # beginning of a line, i.e., following a CRLF, and - # the initial CRLF is considered to be attached to - # the boundary delimiter line rather than part of - # the preceding part. - # - # - The above means that the CRLF before $boundary - # is needed per the RFC, and the parts must not - # have a closing CRLF of their own. See Tcllib bug - # 1213527, and patch 1254934 for the problems when - # both file/string branches added CRLF after the - # body parts. - - - foreach part $state(parts) { - puts $channel \n--$boundary - mime::copymessage $part $channel - } - puts $channel \n--$boundary-- - } - } - - if {[info exists state(fd)]} { - catch {close $state(fd)} - unset state(fd) - } - } - - string { - if {[catch {fconfigure $channel -buffersize} blocksize]} { - set blocksize 4096 - } elseif {$blocksize < 512} { - set blocksize 512 - } - set blocksize [expr {($blocksize / 4) * 3}] - - # [893516] - fconfigure $channel -buffersize $blocksize - - puts $channel {} - - #TODO: tests don't cover these paths - if {$converter eq {}} { - puts -nonewline $channel $state(string) - } else { - puts -nonewline $channel [$converter -mode encode -- $state(string)] - } - } - default { - error "Unknown value \"$state(value)\"" - } - } - - flush $channel - - if {[info exists state(error)]} { - error $state(error) - } -} - -# ::mime::buildmessage -- -# -# Like copymessage, but produces a string rather than writing the message into a channel. -# -# Arguments: -# token The MIME token to parse. -# -# Results: -# The message. - -proc ::mime::buildmessage token { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - set openP [info exists state(fd)] - - set code [catch {mime::buildmessageaux $token} result] - if {![info exists errorCode]} { - set ecode {} - } else { - set ecode $errorCode - } - set einfo $errorInfo - - if {!$openP && [info exists state(fd)]} { - if {![info exists state(root)]} { - catch {close $state(fd)} - } - unset state(fd) - } - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - - -proc ::mime::buildmessageaux token { - set chan [tcl::chan::memchan] - chan configure $chan -translation crlf - copymessageaux $token $chan - seek $chan 0 - chan configure $chan -translation binary - set res [read $chan] - close $chan - return $res -} - -# ::mime::encoding -- -# -# Determines how a token is encoded. -# -# Arguments: -# token The MIME token to parse. -# -# Results: -# Returns the encoding of the message (the null string, base64, -# or quoted-printable). - -proc ::mime::encoding {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - switch -glob -- $state(content) { - audio/* - - - image/* - - - video/* { - return base64 - } - - message/* - - - multipart/* { - return {} - } - default {# Skip} - } - - set asciiP 1 - set lineP 1 - switch -- $state(value) { - file { - set fd [open $state(file) RDONLY] - fconfigure $fd -translation binary - - while {[gets $fd line] >= 0} { - if {$asciiP} { - set asciiP [encodingasciiP $line] - } - if {$lineP} { - set lineP [encodinglineP $line] - } - if {(!$asciiP) && (!$lineP)} { - break - } - } - - catch {close $fd} - } - - parts { - return {} - } - - string { - foreach line [split $state(string) "\n"] { - if {$asciiP} { - set asciiP [encodingasciiP $line] - } - if {$lineP} { - set lineP [encodinglineP $line] - } - if {(!$asciiP) && (!$lineP)} { - break - } - } - } - default { - error "Unknown value \"$state(value)\"" - } - } - - switch -glob -- $state(content) { - text/* { - if {!$asciiP} { - #TODO: this path is not covered by tests - foreach {k v} $state(params) { - if {$k eq "charset"} { - set v [string tolower $v] - if {($v ne "us-ascii") \ - && (![string match {iso-8859-[1-8]} $v])} { - return base64 - } - - break - } - } - } - - if {!$lineP} { - return quoted-printable - } - } - - - default { - if {(!$asciiP) || (!$lineP)} { - return base64 - } - } - } - - return {} -} - -# ::mime::encodingasciiP -- -# -# Checks if a string is a pure ascii string, or if it has a non-standard -# form. -# -# Arguments: -# line The line to check. -# -# Results: -# Returns 1 if \r only occurs at the end of lines, and if all -# characters in the line are between the ASCII codes of 32 and 126. - -proc ::mime::encodingasciiP {line} { - foreach c [split $line {}] { - switch -- $c { - { } - \t - \r - \n { - } - - default { - binary scan $c c c - if {($c < 32) || ($c > 126)} { - return 0 - } - } - } - } - if { - [set r [string first \r $line]] < 0 - || - $r == {[string length $line] - 1} - } { - return 1 - } - - return 0 -} - -# ::mime::encodinglineP -- -# -# Checks if a string is a line is valid to be processed. -# -# Arguments: -# line The line to check. -# -# Results: -# Returns 1 the line is less than 76 characters long, the line -# contains more characters than just whitespace, the line does -# not start with a '.', and the line does not start with 'From '. - -proc ::mime::encodinglineP {line} { - if {([string length $line] > 76) \ - || ($line ne [string trimright $line]) \ - || ([string first . $line] == 0) \ - || ([string first {From } $line] == 0)} { - return 0 - } - - return 1 -} - -# ::mime::fcopy -- -# -# Appears to be unused. -# -# Arguments: -# -# Results: -# - -proc ::mime::fcopy {token count {error {}}} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {$error ne {}} { - set state(error) $error - } - set state(doneP) 1 -} - -# ::mime::scopy -- -# -# Copy a portion of the contents of a mime token to a channel. -# -# Arguments: -# token The token containing the data to copy. -# channel The channel to write the data to. -# offset The location in the string to start copying -# from. -# len The amount of data to write. -# blocksize The block size for the write operation. -# -# Results: -# The specified portion of the string in the mime token is -# copied to the specified channel. - -proc ::mime::scopy {token channel offset len blocksize} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {$len <= 0} { - set state(doneP) 1 - fileevent $channel writable {} - return - } - - if {[set cc $len] > $blocksize} { - set cc $blocksize - } - - if {[catch { - puts -nonewline $channel [ - string range $state(string) $offset [expr {$offset + $cc - 1}]] - fileevent $channel writable [ - list mime::scopy $token $channel [ - incr offset $cc] [incr len -$cc] $blocksize] - } result] - } { - set state(error) $result - set state(doneP) 1 - fileevent $channel writable {} - } - return -} - -# ::mime::qp_encode -- -# -# Tcl version of quote-printable encode -# -# Arguments: -# string The string to quote. -# encoded_word Boolean value to determine whether or not encoded words -# (RFC 2047) should be handled or not. (optional) -# -# Results: -# The properly quoted string is returned. - -proc ::mime::qp_encode {string {encoded_word 0} {no_softbreak 0}} { - # 8.1+ improved string manipulation routines used. - # Replace outlying characters, characters that would normally - # be munged by EBCDIC gateways, and special Tcl characters "[\]{} - # with =xx sequence - - if {$encoded_word} { - # Special processing for encoded words (RFC 2047) - set regexp {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF\x09\x5F\x3F]} - lappend mapChars { } _ - } else { - set regexp {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF]} - } - regsub -all -- $regexp $string {[format =%02X [scan "\\&" %c]]} string - - # Replace the format commands with their result - - set string [subst -novariables $string] - - # soft/hard newlines and other - # Funky cases for SMTP compatibility - lappend mapChars " \n" =20\n \t\n =09\n \n\.\n =2E\n "\nFrom " "\n=46rom " - - set string [string map $mapChars $string] - - # Break long lines - ugh - - # Implementation of FR #503336 - if {$no_softbreak} { - set result $string - } else { - set result {} - foreach line [split $string \n] { - while {[string length $line] > 72} { - set chunk [string range $line 0 72] - if {[regexp -- (=|=.)$ $chunk dummy end]} { - - # Don't break in the middle of a code - - set len [expr {72 - [string length $end]}] - set chunk [string range $line 0 $len] - incr len - set line [string range $line $len end] - } else { - set line [string range $line 73 end] - } - append result $chunk=\n - } - append result $line\n - } - - # Trim off last \n, since the above code has the side-effect - # of adding an extra \n to the encoded string and return the - # result. - set result [string range $result 0 end-1] - } - - # If the string ends in space or tab, replace with =xx - - set lastChar [string index $result end] - if {$lastChar eq { }} { - set result [string replace $result end end =20] - } elseif {$lastChar eq "\t"} { - set result [string replace $result end end =09] - } - - return $result -} - -# ::mime::qp_decode -- -# -# Tcl version of quote-printable decode -# -# Arguments: -# string The quoted-printable string to decode. -# encoded_word Boolean value to determine whether or not encoded words -# (RFC 2047) should be handled or not. (optional) -# -# Results: -# The decoded string is returned. - -proc ::mime::qp_decode {string {encoded_word 0}} { - # 8.1+ improved string manipulation routines used. - # Special processing for encoded words (RFC 2047) - - if {$encoded_word} { - # _ == \x20, even if SPACE occupies a different code position - set string [string map [list _ \u0020] $string] - } - - # smash the white-space at the ends of lines since that must've been - # generated by an MUA. - - regsub -all -- {[ \t]+\n} $string \n string - set string [string trimright $string " \t"] - - # Protect the backslash for later subst and - # smash soft newlines, has to occur after white-space smash - # and any encoded word modification. - - #TODO: codepath not tested - set string [string map [list \\ {\\} =\n {}] $string] - - # Decode specials - - regsub -all -nocase {=([a-f0-9][a-f0-9])} $string {\\u00\1} string - - # process \u unicode mapped chars - - return [subst -novariables -nocommands $string] -} - -# ::mime::parseaddress -- -# -# This was originally written circa 1982 in C. we're still using it -# because it recognizes virtually every buggy address syntax ever -# generated! -# -# mime::parseaddress takes a string containing one or more 822-style -# address specifications and returns a list of dictionaries, for each -# address specified in the argument. -# -# Each dictionary contains these properties: -# -# property value -# ======== ===== -# address local@domain -# comment 822-style comment -# domain the domain part (rhs) -# error non-empty on a parse error -# group this address begins a group -# friendly user-friendly rendering -# local the local part (lhs) -# memberP this address belongs to a group -# phrase the phrase part -# proper 822-style address specification -# route 822-style route specification (obsolete) -# -# Note that one or more of these properties may be empty. -# -# Arguments: -# string The address string to parse -# -# Results: -# Returns a list of dictionaries, one element for each address -# specified in the argument. - -proc ::mime::parseaddress {string} { - global errorCode errorInfo - - variable mime - - set token [namespace current]::[incr mime(uid)] - # FRINK: nocheck - variable $token - upvar 0 $token state - - set code [catch {mime::parseaddressaux $token $string} result] - set ecode $errorCode - set einfo $errorInfo - - foreach name [array names state] { - unset state($name) - } - # FRINK: nocheck - catch {unset $token} - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::mime::parseaddressaux -- -# -# This was originally written circa 1982 in C. we're still using it -# because it recognizes virtually every buggy address syntax ever -# generated! -# -# mime::parseaddressaux does the actually parsing for mime::parseaddress -# -# Each dictionary contains these properties: -# -# property value -# ======== ===== -# address local@domain -# comment 822-style comment -# domain the domain part (rhs) -# error non-empty on a parse error -# group this address begins a group -# friendly user-friendly rendering -# local the local part (lhs) -# memberP this address belongs to a group -# phrase the phrase part -# proper 822-style address specification -# route 822-style route specification (obsolete) -# -# Note that one or more of these properties may be empty. -# -# Arguments: -# token The MIME token to work from. -# string The address string to parse -# -# Results: -# Returns a list of dictionaries, one for each address specified in the -# argument. - -proc ::mime::parseaddressaux {token string} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - variable addrtokenL - variable addrlexemeL - - set state(input) $string - set state(glevel) 0 - set state(buffer) {} - set state(lastC) LX_END - set state(tokenL) $addrtokenL - set state(lexemeL) $addrlexemeL - - set result {} - while {[addr_next $token]} { - if {[set tail $state(domain)] ne {}} { - set tail @$state(domain) - } else { - set tail @[info hostname] - } - if {[set address $state(local)] ne {}} { - #TODO: this path is not covered by tests - append address $tail - } - - if {$state(phrase) ne {}} { - #TODO: this path is not covered by tests - set state(phrase) [string trim $state(phrase) \"] - foreach t $state(tokenL) { - if {[string first $t $state(phrase)] >= 0} { - #TODO: is this quoting robust enough? - set state(phrase) \"$state(phrase)\" - break - } - } - - set proper "$state(phrase) <$address>" - } else { - set proper $address - } - - if {[set friendly $state(phrase)] eq {}} { - #TODO: this path is not covered by tests - if {[set note $state(comment)] ne {}} { - if {[string first ( $note] == 0} { - set note [string trimleft [string range $note 1 end]] - } - if { - [string last ) $note] - == [set len [expr {[string length $note] - 1}]] - } { - set note [string range $note 0 [expr {$len - 1}]] - } - set friendly $note - } - - if { - $friendly eq {} - && - [set mbox $state(local)] ne {} - } { - #TODO: this path is not covered by tests - set mbox [string trim $mbox \"] - - if {[string first / $mbox] != 0} { - set friendly $mbox - } elseif {[set friendly [addr_x400 $mbox PN]] ne {}} { - } elseif { - [set friendly [addr_x400 $mbox S]] ne {} - && - [set g [addr_x400 $mbox G]] ne {} - } { - set friendly "$g $friendly" - } - - if {$friendly eq {}} { - set friendly $mbox - } - } - } - set friendly [string trim $friendly \"] - - lappend result [list address $address \ - comment $state(comment) \ - domain $state(domain) \ - error $state(error) \ - friendly $friendly \ - group $state(group) \ - local $state(local) \ - memberP $state(memberP) \ - phrase $state(phrase) \ - proper $proper \ - route $state(route)] - - } - - unset {*}{ - state(input) - state(glevel) - state(buffer) - state(lastC) - state(tokenL) - state(lexemeL) - } - - return $result -} - -# ::mime::addr_next -- -# -# Locate the next address in a mime token. -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns 1 if there is another address, and 0 if there is not. - -proc ::mime::addr_next {token} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - set nocomplain [package vsatisfies [package provide Tcl] 8.4] - foreach prop {comment domain error group local memberP phrase route} { - if {$nocomplain} { - unset -nocomplain state($prop) - } else { - if {[catch {unset state($prop)}]} {set ::errorInfo {}} - } - } - - switch -- [set code [catch {mime::addr_specification $token} result]] { - 0 { - if {!$result} { - return 0 - } - - switch -- $state(lastC) { - LX_COMMA - - - LX_END { - } - default { - # catch trailing comments... - set lookahead $state(input) - mime::parselexeme $token - set state(input) $lookahead - } - } - } - - 7 { - set state(error) $result - - while {1} { - switch -- $state(lastC) { - LX_COMMA - - - LX_END { - break - } - - default { - mime::parselexeme $token - } - } - } - } - - default { - set ecode $errorCode - set einfo $errorInfo - - return -code $code -errorinfo $einfo -errorcode $ecode $result - } - } - - foreach prop {comment domain error group local memberP phrase route} { - if {![info exists state($prop)]} { - set state($prop) {} - } - } - - return 1 -} - -# ::mime::addr_specification -- -# -# Uses lookahead parsing to determine whether there is another -# valid e-mail address or not. Throws errors if unrecognized -# or invalid e-mail address syntax is used. -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns 1 if there is another address, and 0 if there is not. - -proc ::mime::addr_specification {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - set lookahead $state(input) - switch -- [parselexeme $token] { - LX_ATOM - - - LX_QSTRING { - set state(phrase) $state(buffer) - } - - LX_SEMICOLON { - if {[incr state(glevel) -1] < 0} { - return -code 7 "extraneous semi-colon" - } - - catch {unset state(comment)} - return [addr_specification $token] - } - - LX_COMMA { - catch {unset state(comment)} - return [addr_specification $token] - } - - LX_END { - return 0 - } - - LX_LBRACKET { - return [addr_routeaddr $token] - } - - LX_ATSIGN { - set state(input) $lookahead - return [addr_routeaddr $token 0] - } - - default { - return -code 7 [ - format "unexpected character at beginning (found %s)" \ - $state(buffer)] - } - } - - switch -- [parselexeme $token] { - LX_ATOM - - - LX_QSTRING { - append state(phrase) " " $state(buffer) - - return [addr_phrase $token] - } - - LX_LBRACKET { - return [addr_routeaddr $token] - } - - LX_COLON { - return [addr_group $token] - } - - LX_DOT { - set state(local) "$state(phrase)$state(buffer)" - unset state(phrase) - mime::addr_routeaddr $token 0 - mime::addr_end $token - } - - LX_ATSIGN { - set state(memberP) $state(glevel) - set state(local) $state(phrase) - unset state(phrase) - mime::addr_domain $token - mime::addr_end $token - } - - LX_SEMICOLON - - - LX_COMMA - - - LX_END { - set state(memberP) $state(glevel) - if { - $state(lastC) eq "LX_SEMICOLON" - && - ([incr state(glevel) -1] < 0) - } { - #TODO: this path is not covered by tests - return -code 7 "extraneous semi-colon" - } - - set state(local) $state(phrase) - unset state(phrase) - } - - default { - return -code 7 [ - format "expecting mailbox (found %s)" $state(buffer)] - } - } - - return 1 -} - -# ::mime::addr_routeaddr -- -# -# Parses the domain portion of an e-mail address. Finds the '@' -# sign and then calls mime::addr_route to verify the domain. -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns 1 if there is another address, and 0 if there is not. - -proc ::mime::addr_routeaddr {token {checkP 1}} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - set lookahead $state(input) - if {[parselexeme $token] eq "LX_ATSIGN"} { - #TODO: this path is not covered by tests - mime::addr_route $token - } else { - set state(input) $lookahead - } - - mime::addr_local $token - - switch -- $state(lastC) { - LX_ATSIGN { - mime::addr_domain $token - } - - LX_SEMICOLON - - - LX_RBRACKET - - - LX_COMMA - - - LX_END { - } - - default { - return -code 7 [ - format "expecting at-sign after local-part (found %s)" \ - $state(buffer)] - } - } - - if {($checkP) && ($state(lastC) ne "LX_RBRACKET")} { - return -code 7 [ - format "expecting right-bracket (found %s)" $state(buffer)] - } - - return 1 -} - -# ::mime::addr_route -- -# -# Attempts to parse the portion of the e-mail address after the @. -# Tries to verify that the domain definition has a valid form. -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_route {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - set state(route) @ - - while 1 { - switch -- [parselexeme $token] { - LX_ATOM - - - LX_DLITERAL { - append state(route) $state(buffer) - } - - default { - return -code 7 \ - [format "expecting sub-route in route-part (found %s)" \ - $state(buffer)] - } - } - - switch -- [parselexeme $token] { - LX_COMMA { - append state(route) $state(buffer) - while 1 { - switch -- [parselexeme $token] { - LX_COMMA { - } - - LX_ATSIGN { - append state(route) $state(buffer) - break - } - - default { - return -code 7 \ - [format "expecting at-sign in route (found %s)" \ - $state(buffer)] - } - } - } - } - - LX_ATSIGN - - - LX_DOT { - append state(route) $state(buffer) - } - - LX_COLON { - append state(route) $state(buffer) - return - } - - default { - return -code 7 [ - format "expecting colon to terminate route (found %s)" \ - $state(buffer)] - } - } - } -} - -# ::mime::addr_domain -- -# -# Attempts to parse the portion of the e-mail address after the @. -# Tries to verify that the domain definition has a valid form. -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_domain {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - while 1 { - switch -- [parselexeme $token] { - LX_ATOM - - - LX_DLITERAL { - append state(domain) $state(buffer) - } - - default { - return -code 7 [ - format "expecting sub-domain in domain-part (found %s)" \ - $state(buffer)] - } - } - - switch -- [parselexeme $token] { - LX_DOT { - append state(domain) $state(buffer) - } - - LX_ATSIGN { - append state(local) % $state(domain) - unset state(domain) - } - - default { - return - } - } - } -} - -# ::mime::addr_local -- -# -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_local {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - set state(memberP) $state(glevel) - - while 1 { - switch -- [parselexeme $token] { - LX_ATOM - - - LX_QSTRING { - append state(local) $state(buffer) - } - - default { - return -code 7 \ - [format "expecting mailbox in local-part (found %s)" \ - $state(buffer)] - } - } - - switch -- [parselexeme $token] { - LX_DOT { - append state(local) $state(buffer) - } - - default { - return - } - } - } -} - -# ::mime::addr_phrase -- -# -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - - -proc ::mime::addr_phrase {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - while {1} { - switch -- [parselexeme $token] { - LX_ATOM - - - LX_QSTRING { - append state(phrase) " " $state(buffer) - } - - default { - break - } - } - } - - switch -- $state(lastC) { - LX_LBRACKET { - return [addr_routeaddr $token] - } - - LX_COLON { - return [addr_group $token] - } - - LX_DOT { - append state(phrase) $state(buffer) - return [addr_phrase $token] - } - - default { - return -code 7 [ - format "found phrase instead of mailbox (%s%s)" \ - $state(phrase) $state(buffer)] - } - } -} - -# ::mime::addr_group -- -# -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_group {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {[incr state(glevel)] > 1} { - return -code 7 [ - format "nested groups not allowed (found %s)" $state(phrase)] - } - - set state(group) $state(phrase) - unset state(phrase) - - set lookahead $state(input) - while 1 { - switch -- [parselexeme $token] { - LX_SEMICOLON - - - LX_END { - set state(glevel) 0 - return 1 - } - - LX_COMMA { - } - - default { - set state(input) $lookahead - return [addr_specification $token] - } - } - } -} - -# ::mime::addr_end -- -# -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_end {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - switch -- $state(lastC) { - LX_SEMICOLON { - if {[incr state(glevel) -1] < 0} { - return -code 7 "extraneous semi-colon" - } - } - - LX_COMMA - - - LX_END { - } - - default { - return -code 7 [ - format "junk after local@domain (found %s)" $state(buffer)] - } - } -} - -# ::mime::addr_x400 -- -# -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_x400 {mbox key} { - if {[set x [string first /$key= [string toupper $mbox]]] < 0} { - return {} - } - set mbox [string range $mbox [expr {$x + [string length $key] + 2}] end] - - if {[set x [string first / $mbox]] > 0} { - set mbox [string range $mbox 0 [expr {$x - 1}]] - } - - return [string trim $mbox \"] -} - -# ::mime::parsedatetime -- -# -# Fortunately the clock command in the Tcl 8.x core does all the heavy -# lifting for us (except for timezone calculations). -# -# mime::parsedatetime takes a string containing an 822-style date-time -# specification and returns the specified property. -# -# The list of properties and their ranges are: -# -# property range -# ======== ===== -# clock raw result of "clock scan" -# hour 0 .. 23 -# lmonth January, February, ..., December -# lweekday Sunday, Monday, ... Saturday -# mday 1 .. 31 -# min 0 .. 59 -# mon 1 .. 12 -# month Jan, Feb, ..., Dec -# proper 822-style date-time specification -# rclock elapsed seconds between then and now -# sec 0 .. 59 -# wday 0 .. 6 (Sun .. Mon) -# weekday Sun, Mon, ..., Sat -# yday 1 .. 366 -# year 1900 ... -# zone -720 .. 720 (minutes east of GMT) -# -# Arguments: -# value Either a 822-style date-time specification or '-now' -# if the current date/time should be used. -# property The property (from the list above) to return -# -# Results: -# Returns the string value of the 'property' for the date/time that was -# specified in 'value'. - -namespace eval ::mime { - variable WDAYS_SHORT [list Sun Mon Tue Wed Thu Fri Sat] - variable WDAYS_LONG [list Sunday Monday Tuesday Wednesday Thursday \ - Friday Saturday] - - # Counting months starts at 1, so just insert a dummy element - # at index 0. - variable MONTHS_SHORT [list {} \ - Jan Feb Mar Apr May Jun \ - Jul Aug Sep Oct Nov Dec] - variable MONTHS_LONG [list {} \ - January February March April May June July \ - August Sepember October November December] -} -proc ::mime::parsedatetime {value property} { - if {$value eq "-now"} { - set clock [clock seconds] - } elseif {[regexp {^(.*) ([+-])([0-9][0-9])([0-9][0-9])$} $value \ - -> value zone_sign zone_hour zone_min] - } { - set clock [clock scan $value -gmt 1] - if {[info exists zone_min]} { - set zone_min [scan $zone_min %d] - set zone_hour [scan $zone_hour %d] - set zone [expr {60 * ($zone_min + 60 * $zone_hour)}] - if {$zone_sign eq "+"} { - set zone -$zone - } - incr clock $zone - } - } else { - set clock [clock scan $value] - } - - switch -- $property { - clock { - return $clock - } - - hour { - set value [clock format $clock -format %H] - } - - lmonth { - variable MONTHS_LONG - return [lindex $MONTHS_LONG \ - [scan [clock format $clock -format %m] %d]] - } - - lweekday { - variable WDAYS_LONG - return [lindex $WDAYS_LONG [clock format $clock -format %w]] - } - - mday { - set value [clock format $clock -format %d] - } - - min { - set value [clock format $clock -format %M] - } - - mon { - set value [clock format $clock -format %m] - } - - month { - variable MONTHS_SHORT - return [lindex $MONTHS_SHORT [ - scan [clock format $clock -format %m] %d]] - } - - proper { - set gmt [clock format $clock -format "%Y-%m-%d %H:%M:%S" -gmt true] - if {[set diff [expr {($clock-[clock scan $gmt]) / 60}]] < 0} { - set s - - set diff [expr {-($diff)}] - } else { - set s + - } - set zone [format %s%02d%02d $s [ - expr {$diff / 60}] [expr {$diff % 60}]] - - variable WDAYS_SHORT - set wday [lindex $WDAYS_SHORT [clock format $clock -format %w]] - variable MONTHS_SHORT - set mon [lindex $MONTHS_SHORT [ - scan [clock format $clock -format %m] %d]] - - return [ - clock format $clock -format "$wday, %d $mon %Y %H:%M:%S $zone"] - } - - rclock { - #TODO: these paths are not covered by tests - if {$value eq "-now"} { - return 0 - } else { - return [expr {[clock seconds] - $clock}] - } - } - - sec { - set value [clock format $clock -format %S] - } - - wday { - return [clock format $clock -format %w] - } - - weekday { - variable WDAYS_SHORT - return [lindex $WDAYS_SHORT [clock format $clock -format %w]] - } - - yday { - set value [clock format $clock -format %j] - } - - year { - set value [clock format $clock -format %Y] - } - - zone { - set value [string trim [string map [list \t { }] $value]] - if {[set x [string last { } $value]] < 0} { - return 0 - } - set value [string range $value [expr {$x + 1}] end] - switch -- [set s [string index $value 0]] { - + - - { - if {$s eq "+"} { - #TODO: This path is not covered by tests - set s {} - } - set value [string trim [string range $value 1 end]] - if {( - [string length $value] != 4) - || - [scan $value %2d%2d h m] != 2 - || - $h > 12 - || - $m > 59 - || - ($h == 12 && $m > 0) - } { - error "malformed timezone-specification: $value" - } - set value $s[expr {$h * 60 + $m}] - } - - default { - set value [string toupper $value] - set z1 [list UT GMT EST EDT CST CDT MST MDT PST PDT] - set z2 [list 0 0 -5 -4 -6 -5 -7 -6 -8 -7] - if {[set x [lsearch -exact $z1 $value]] < 0} { - error "unrecognized timezone-mnemonic: $value" - } - set value [expr {[lindex $z2 $x] * 60}] - } - } - } - - date2gmt - - - date2local - - - dst - - - sday - - - szone - - - tzone - - - default { - error "unknown property $property" - } - } - - if {[set value [string trimleft $value 0]] eq {}} { - #TODO: this path is not covered by tests - set value 0 - } - return $value -} - -# ::mime::uniqueID -- -# -# Used to generate a 'globally unique identifier' for the content-id. -# The id is built from the pid, the current time, the hostname, and -# a counter that is incremented each time a message is sent. -# -# Arguments: -# -# Results: -# Returns the a string that contains the globally unique identifier -# that should be used for the Content-ID of an e-mail message. - -proc ::mime::uniqueID {} { - variable mime - - return <[pid].[clock seconds].[incr mime(cid)]@[info hostname]> -} - -# ::mime::parselexeme -- -# -# Used to implement a lookahead parser. -# -# Arguments: -# token The MIME token to operate on. -# -# Results: -# Returns the next token found by the parser. - -proc ::mime::parselexeme {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - set state(input) [string trimleft $state(input)] - - set state(buffer) {} - if {$state(input) eq {}} { - set state(buffer) end-of-input - return [set state(lastC) LX_END] - } - - set c [string index $state(input) 0] - set state(input) [string range $state(input) 1 end] - - if {$c eq "("} { - set noteP 0 - set quoteP 0 - - while 1 { - append state(buffer) $c - - #TODO: some of these paths are not covered by tests - switch -- $c/$quoteP { - (/0 { - incr noteP - } - - \\/0 { - set quoteP 1 - } - - )/0 { - if {[incr noteP -1] < 1} { - if {[info exists state(comment)]} { - append state(comment) { } - } - append state(comment) $state(buffer) - - return [parselexeme $token] - } - } - - default { - set quoteP 0 - } - } - - if {[set c [string index $state(input) 0]] eq {}} { - set state(buffer) "end-of-input during comment" - return [set state(lastC) LX_ERR] - } - set state(input) [string range $state(input) 1 end] - } - } - - if {$c eq "\""} { - set firstP 1 - set quoteP 0 - - while 1 { - append state(buffer) $c - - switch -- $c/$quoteP { - "\\/0" { - set quoteP 1 - } - - "\"/0" { - if {!$firstP} { - return [set state(lastC) LX_QSTRING] - } - set firstP 0 - } - - default { - set quoteP 0 - } - } - - if {[set c [string index $state(input) 0]] eq {}} { - set state(buffer) "end-of-input during quoted-string" - return [set state(lastC) LX_ERR] - } - set state(input) [string range $state(input) 1 end] - } - } - - if {$c eq {[}} { - set quoteP 0 - - while 1 { - append state(buffer) $c - - switch -- $c/$quoteP { - \\/0 { - set quoteP 1 - } - - ]/0 { - return [set state(lastC) LX_DLITERAL] - } - - default { - set quoteP 0 - } - } - - if {[set c [string index $state(input) 0]] eq {}} { - set state(buffer) "end-of-input during domain-literal" - return [set state(lastC) LX_ERR] - } - set state(input) [string range $state(input) 1 end] - } - } - - if {[set x [lsearch -exact $state(tokenL) $c]] >= 0} { - append state(buffer) $c - - return [set state(lastC) [lindex $state(lexemeL) $x]] - } - - while 1 { - append state(buffer) $c - - switch -- [set c [string index $state(input) 0]] { - {} - " " - "\t" - "\n" { - break - } - - default { - if {[lsearch -exact $state(tokenL) $c] >= 0} { - break - } - } - } - - set state(input) [string range $state(input) 1 end] - } - - return [set state(lastC) LX_ATOM] -} - -# ::mime::mapencoding -- -# -# mime::mapencodings maps tcl encodings onto the proper names for their -# MIME charset type. This is only done for encodings whose charset types -# were known. The remaining encodings return {} for now. -# -# Arguments: -# enc The tcl encoding to map. -# -# Results: -# Returns the MIME charset type for the specified tcl encoding, or {} -# if none is known. - -proc ::mime::mapencoding {enc} { - - variable encodings - - if {[info exists encodings($enc)]} { - return $encodings($enc) - } - return {} -} - -# ::mime::reversemapencoding -- -# -# mime::reversemapencodings maps MIME charset types onto tcl encoding names. -# Those that are unknown return {}. -# -# Arguments: -# mimeType The MIME charset to convert into a tcl encoding type. -# -# Results: -# Returns the tcl encoding name for the specified mime charset, or {} -# if none is known. - -proc ::mime::reversemapencoding {mimeType} { - - variable reversemap - - set lmimeType [string tolower $mimeType] - if {[info exists reversemap($lmimeType)]} { - return $reversemap($lmimeType) - } - return {} -} - -# ::mime::word_encode -- -# -# Word encodes strings as per RFC 2047. -# -# Arguments: -# charset The character set to encode the message to. -# method The encoding method (base64 or quoted-printable). -# string The string to encode. -# ?-charset_encoded 0 or 1 Whether the data is already encoded -# in the specified charset (default 1) -# ?-maxlength maxlength The maximum length of each encoded -# word to return (default 66) -# -# Results: -# Returns a word encoded string. - -proc ::mime::word_encode {charset method string {args}} { - - variable encodings - - if {![info exists encodings($charset)]} { - error "unknown charset '$charset'" - } - - if {$encodings($charset) eq {}} { - error "invalid charset '$charset'" - } - - if {$method ne "base64" && $method ne "quoted-printable"} { - error "unknown method '$method', must be base64 or quoted-printable" - } - - # default to encoded and a length that won't make the Subject header to long - array set options [list -charset_encoded 1 -maxlength 66] - array set options $args - - if {$options(-charset_encoded)} { - set unencoded_string [::encoding convertfrom $charset $string] - } else { - set unencoded_string $string - } - - set string_length [string length $unencoded_string] - - if {!$string_length} { - return {} - } - - set string_bytelength [string bytelength $unencoded_string] - - # the 7 is for =?, ?Q?, ?= delimiters of the encoded word - set maxlength [expr {$options(-maxlength) - [string length $encodings($charset)] - 7}] - switch -exact -- $method { - base64 { - if {$maxlength < 4} { - error "maxlength $options(-maxlength) too short for chosen charset and encoding" - } - set count 0 - set maxlength [expr {($maxlength / 4) * 3}] - while {$count < $string_length} { - set length 0 - set enc_string {} - while {$length < $maxlength && $count < $string_length} { - set char [string range $unencoded_string $count $count] - set enc_char [::encoding convertto $charset $char] - if {$length + [string length $enc_char] > $maxlength} { - set length $maxlength - } else { - append enc_string $enc_char - incr count - incr length [string length $enc_char] - } - } - set encoded_word [string map [ - list \n {}] [base64 -mode encode -- $enc_string]] - append result "=?$encodings($charset)?B?$encoded_word?=\n " - } - # Trim off last "\n ", since the above code has the side-effect - # of adding an extra "\n " to the encoded string. - - set result [string range $result 0 end-2] - } - quoted-printable { - if {$maxlength < 1} { - error "maxlength $options(-maxlength) too short for chosen charset and encoding" - } - set count 0 - while {$count < $string_length} { - set length 0 - set encoded_word {} - while {$length < $maxlength && $count < $string_length} { - set char [string range $unencoded_string $count $count] - set enc_char [::encoding convertto $charset $char] - set qp_enc_char [qp_encode $enc_char 1] - set qp_enc_char_length [string length $qp_enc_char] - if {$qp_enc_char_length > $maxlength} { - error "maxlength $options(-maxlength) too short for chosen charset and encoding" - } - if { - $length + [string length $qp_enc_char] > $maxlength - } { - set length $maxlength - } else { - append encoded_word $qp_enc_char - incr count - incr length [string length $qp_enc_char] - } - } - append result "=?$encodings($charset)?Q?$encoded_word?=\n " - } - # Trim off last "\n ", since the above code has the side-effect - # of adding an extra "\n " to the encoded string. - - set result [string range $result 0 end-2] - } - {} { - # Go ahead - } - default { - error "Can't handle content encoding \"$method\"" - } - } - return $result -} - -# ::mime::word_decode -- -# -# Word decodes strings that have been word encoded as per RFC 2047. -# -# Arguments: -# encoded The word encoded string to decode. -# -# Results: -# Returns the string that has been decoded from the encoded message. - -proc ::mime::word_decode {encoded} { - - variable reversemap - - if {[regexp -- {=\?([^?]+)\?(.)\?([^?]*)\?=} $encoded \ - - charset method string] != 1 - } { - error "malformed word-encoded expression '$encoded'" - } - - set enc [reversemapencoding $charset] - if {$enc eq {}} { - error "unknown charset '$charset'" - } - - switch -exact -- $method { - b - - B { - set method base64 - } - q - - Q { - set method quoted-printable - } - default { - error "unknown method '$method', must be B or Q" - } - } - - switch -exact -- $method { - base64 { - set result [base64 -mode decode -- $string] - } - quoted-printable { - set result [qp_decode $string 1] - } - {} { - # Go ahead - } - default { - error "Can't handle content encoding \"$method\"" - } - } - - return [list $enc $method $result] -} - -# ::mime::field_decode -- -# -# Word decodes strings that have been word encoded as per RFC 2047 -# and converts the string from the original encoding/charset to UTF. -# -# Arguments: -# field The string to decode -# -# Results: -# Returns the decoded string in UTF. - -proc ::mime::field_decode {field} { - # ::mime::field_decode is broken. Here's a new version. - # This code is in the public domain. Don Libes - - # Step through a field for mime-encoded words, building a new - # version with unencoded equivalents. - - # Sorry about the grotesque regexp. Most of it is sensible. One - # notable fudge: the final $ is needed because of an apparent bug - # in the regexp engine where the preceding .* otherwise becomes - # non-greedy - perhaps because of the earlier ".*?", sigh. - - while {[regexp {(.*?)(=\?(?:[^?]+)\?(?:.)\?(?:[^?]*)\?=)(.*)$} $field \ - ignore prefix encoded field] - } { - # don't allow whitespace between encoded words per RFC 2047 - if {{} ne $prefix} { - if {![string is space $prefix]} { - append result $prefix - } - } - - set decoded [word_decode $encoded] - foreach {charset - string} $decoded break - - append result [::encoding convertfrom $charset $string] - } - append result $field - return $result -} - -## One-Shot Initialization - -::apply {{} { - variable encList - variable encAliasList - variable reversemap - - foreach {enc mimeType} $encList { - if {$mimeType eq {}} continue - set reversemap([string tolower $mimeType]) $enc - } - - foreach {enc mimeType} $encAliasList { - set reversemap([string tolower $mimeType]) $enc - } - - # Drop the helper variables - unset encList encAliasList - -} ::mime} - - -variable ::mime::internal 0 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.3.tm deleted file mode 100644 index 540a1696..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.3.tm +++ /dev/null @@ -1,709 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# 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) 2024 -# -# @@ Meta Begin -# Application modpod 0.1.3 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin modpod_module_modpod 0 0.1.3] -#[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require modpod] -#[keywords module] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of modpod -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by modpod -#[list_begin itemized] - -package require Tcl 8.6- -package require struct::set ;#review -package require punk::lib -package require punk::args -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod::class { - #*** !doctools - #[subsection {Namespace modpod::class}] - #[para] class definitions - if {[info commands [namespace current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod { - namespace export {[a-z]*}; # Convention: export all lowercase - - variable connected - if {![info exists connected(to)]} { - set connected(to) list - } - variable modpodscript - set modpodscript [info script] - if {[string tolower [file extension $modpodscript]] eq ".tcl"} { - set connected(self) [file dirname $modpodscript] - } else { - #expecting a .tm - set connected(self) $modpodscript - } - variable loadables [info sharedlibextension] - variable sourceables {.tcl .tk} ;# .tm ? - - #*** !doctools - #[subsection {Namespace modpod}] - #[para] Core API functions for modpod - #[list_begin definitions] - - - - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - - #old tar connect mechanism - review - not needed? - proc connect {args} { - puts stderr "modpod::connect--->>$args" - set argd [punk::args::parse $args withdef { - @id -id ::modpod::connect - -type -default "" - @values -min 1 -max 1 - path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" - }] - catch { - punk::lib::showdict $argd ;#heavy dependencies - } - set opt_path [dict get $argd values path] - variable connected - set original_connectpath $opt_path - set modpodpath [modpod::system::normalize $opt_path] ;# - - if {$modpodpath in $connected(to)} { - return [dict create ok ALREADY_CONNECTED] - } - lappend connected(to) $modpodpath - - set connected(connectpath,$opt_path) $original_connectpath - set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] - - set connected(location,$modpodpath) [file dirname $modpodpath] - set connected(startdata,$modpodpath) -1 - set connected(type,$modpodpath) [dict get $argd opts -type] - set connected(fh,$modpodpath) "" - - if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { - set connected(type,$modpodpath) "unwrapped" - lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) - set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] - - } else { - #connect to .tm but may still be unwrapped version available - lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) - set this_pkg_tm_folder [file dirname $modpodpath] - if {$connected(type,$modpodpath) ne "unwrapped"} { - #Not directly connected to unwrapped version - but may still be redirected there - set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] - if {[file exists $unwrappedFolder]} { - #folder with exact version-match must exist for redirect to 'unwrapped' - set con(type,$modpodpath) "modpod-redirecting" - } - } - - } - set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" - set connected(tmfile,$modpodpath) - set tail_segments [list] - set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] - set lcase_modulepaths [string tolower [tcl::tm::list]] - foreach lc_mpath $lcase_modulepaths { - set mpath_segments [file split $lc_mpath] - if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { - set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] - break - } - } - if {[llength $tail_segments]} { - set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require - } else { - set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] - } - - switch -exact -- $connected(type,$modpodpath) { - "modpod-redirecting" { - #redirect to the unwrapped version - set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] - - } - "unwrapped" { - if {[info commands ::thread::id] ne ""} { - set from [pid],[thread::id] - } else { - set from [pid] - } - #::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" - return [list ok ""] - } - default { - #autodetect .tm - zip/tar ? - #todo - use vfs ? - - #connect to tarball - start at 1st header - set connected(startdata,$modpodpath) 0 - set fh [open $modpodpath r] - set connected(fh,$modpodpath) $fh - fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} - - if {$connected(startdata,$modpodpath) >= 0} { - #verify we have a valid tar header - if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} { - seek $fh $connected(startdata,$modpodpath) start - return [list ok $fh] - } else { - #error "cannot verify tar header" - #try zipfs - if {[info commands tcl::zipfs::mount] ne ""} { - - } - } - } - lpop connected(to) end - set connected(startdata,$modpodpath) -1 - unset connected(fh,$modpodpath) - catch {close $fh} - return [dict create err {Does not appear to be a valid modpod}] - } - } - } - proc disconnect {{modpod ""}} { - variable connected - if {![llength $connected(to)]} { - return 0 - } - if {$modpod eq ""} { - puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" - set modpod [lindex $connected(to) end] - } - - if {[set posn [lsearch $connected(to) $modpod]] == -1} { - puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" - return 0 - } - if {[string length $connected(fh,$modpod)]} { - close $connected(fh,$modpod) - } - array unset connected *,$modpod - set connected(to) [lreplace $connected(to) $posn $posn] - return 1 - } - proc get {args} { - set argd [punk::args::parse $args withdef { - @id -id ::modpod::get - -from -default "" -help "path to pod" - @values -min 1 -max 1 - filename - }] - set frompod [dict get $argd opts -from] - set filename [dict get $argd values filename] - - variable connected - #//review - set modpod [::modpod::system::connect_if_not $frompod] - set fh $connected(fh,$modpod) - if {$connected(type,$modpod) eq "unwrapped"} { - #for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder - if {[string range $filename 0 0 eq "/"]} { - #absolute path (?) - set path [file join $connected(location,$modpod) .. [string trim $filename /]] - } else { - #relative path - use #modpod-xxx as base - set path [file join $connected(location,$modpod) $filename] - } - set fd [open $path r] - #utf-8? - #fconfigure $fd -encoding iso8859-1 -translation binary - return [list ok [lindex [list [read $fd] [close $fd]] 0]] - } else { - #read from vfs - puts stderr "get $filename from wrapped pod '$frompod' not implemented" - } - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace modpod ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod::lib { - namespace export {[a-z]*}; # Convention: export all lowercase - namespace path [namespace parent] - #*** !doctools - #[subsection {Namespace modpod::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 - #} - - proc is_valid_tm_version {versionpart} { - #Needs to be suitable for use with Tcl's 'package vcompare' - if {![catch [list package vcompare $versionparts $versionparts]]} { - return 1 - } else { - return 0 - } - } - - #zipfile is a pure zip at this point - ie no script/exe header - proc make_zip_modpod {args} { - set argd [punk::args::parse $args withdef { - @id -id ::modpod::lib::make_zip_modpod - -offsettype -default "archive" -choices {archive file} -help\ - "Whether zip offsets are relative to start of file or start of zip-data within the file. - 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, - but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) - info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. - -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" - @values -min 2 -max 2 - zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" - outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" - }] - set zipfile [dict get $argd values zipfile] - set outfile [dict get $argd values outfile] - set opt_offsettype [dict get $argd opts -offsettype] - - - set mount_stub [string map [list %offsettype% $opt_offsettype] { - #zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. - #Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. - #generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% - if {[catch {file normalize [info script]} modfile]} { - error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" - } - if {$modfile eq "" || ![file exists $modfile]} { - error "modpod zip stub error. Unable to determine module path" - } - set moddir [file dirname $modfile] - set mod_and_ver [file rootname [file tail $modfile]] - lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver]} { - source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #determine module namespace so we can mount appropriately - proc intersect {A B} { - if {[llength $A] == 0} {return {}} - if {[llength $B] == 0} {return {}} - if {[llength $B] > [llength $A]} { - set res $A - set A $B - set B $res - } - set res {} - foreach x $A {set ($x) {}} - foreach x $B { - if {[info exists ($x)]} { - lappend res $x - } - } - return $res - } - set lcase_tmfile_segments [string tolower [file split $moddir]] - set lcase_modulepaths [string tolower [tcl::tm::list]] - foreach lc_mpath $lcase_modulepaths { - set mpath_segments [file split $lc_mpath] - if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { - set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail - break - } - } - if {[llength $tail_segments]} { - set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require - set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver - } else { - set fullpackage $moduletail - set mount_at #modpod/#mounted-modpod-$mod_and_ver - } - - if {[info commands tcl::zipfs::mount] ne ""} { - #argument order changed to be consistent with vfs::zip::Mount etc - #early versions: zipfs::Mount mountpoint zipname - #since 2023-09: zipfs::Mount zipname mountpoint - #don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) - #This is presumably related to // being interpreted as a network path - set mountpoints [dict keys [tcl::zipfs::mount]] - if {"//zipfs:/$mount_at" ni $mountpoints} { - #despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it - if {[catch { - #tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) - #puts "tcl::zipfs::mount $modfile $mount_at" - tcl::zipfs::mount $modfile $mount_at - } errM]} { - #try old api - if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { - puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" - puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" - } - } - if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" - #tcl::zipfs::unmount //zipfs:/$mount_at - error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" - } - } - # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form - source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #fallback to slower vfs::zip - #NB. We don't create the intermediate dirs - but the mount still works - if {![file exists $moddir/$mount_at]} { - if {[catch {package require vfs::zip} errM]} { - set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" - append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." - append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" - error $msg - } else { - set fd [vfs::zip::Mount $modfile $moddir/$mount_at] - if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - vfs::zip::Unmount $fd $moddir/$mount_at - error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" - } - } - } - source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm - } - } - #zipped data follows - }] - #todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype - - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace modpod::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -namespace eval modpod::system { - #*** !doctools - #[subsection {Namespace modpod::system}] - #[para] Internal functions that are not part of the API - - #deflate,store only supported - - #zipfile here is plain zip - no script/exe prefix part. - proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { - set inzip [open $zipfile r] - fconfigure $inzip -encoding iso8859-1 -translation binary - set out [open $outfile w+] - fconfigure $out -encoding iso8859-1 -translation binary - puts -nonewline $out $mount_stub - set stuboffset [tell $out] - lappend report "stub size: $stuboffset" - fcopy $inzip $out - close $inzip - - set size [tell $out] - lappend report "modpod::system::make_mountable_zip" - lappend report "tmfile : [file tail $outfile]" - lappend report "output size : $size" - lappend report "offsettype : $offsettype" - - if {$offsettype eq "file"} { - #make zip offsets relative to start of whole file including prepended script. - #same offset structure as Tcl's older 'zipfs mkimg' as at 2024-10 - #2025 - zipfs mkimg fixed to use 'archive' offset. - #not editable by 7z,nanazip,peazip - - #we aren't adding any new files/folders so we can edit the offsets in place - - #Now seek in $out to find the end of directory signature: - #The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text - if {$size < 65559} { - set tailsearch_start 0 - } else { - set tailsearch_start [expr {$size - 65559}] - } - seek $out $tailsearch_start - set data [read $out] - #EOCD - End of Central Directory record - #PK\5\6 - set start_of_end [string last "\x50\x4b\x05\x06" $data] - #set start_of_end [expr {$start_of_end + $seek}] - #incr start_of_end $seek - set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] - - lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" - - seek $out $filerelative_eocd_posn - set end_of_ctrl_dir [read $out] - binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - - lappend report "End of central directory: [array get eocd]" - seek $out [expr {$filerelative_eocd_posn+16}] - - #adjust offset of start of central directory by the length of our sfx stub - puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] - flush $out - - seek $out $filerelative_eocd_posn - set end_of_ctrl_dir [read $out] - binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - - # 0x06054b50 - end of central dir signature - puts stderr "$end_of_ctrl_dir" - puts stderr "comment_len: $eocd(comment_len)" - puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" - lappend report "New dir offset: $eocd(diroffset)" - lappend report "Adjusting $eocd(totalnum) zip file items." - catch { - punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies - } - - seek $out $eocd(diroffset) - for {set i 0} {$i <$eocd(totalnum)} {incr i} { - set current_file [tell $out] - set fileheader [read $out 46] - puts -------------- - puts [ansistring VIEW -lf 1 $fileheader] - puts -------------- - #binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - # x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - - binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - set ::last_header $fileheader - - puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" - puts "ver: $x(version)" - puts "method: $x(method)" - - #PK\1\2 - #33639248 dec = 0x02014b50 - central directory file header signature - if { $x(sig) != 33639248 } { - error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" - } - - foreach size $x(lengths) var {filename extrafield comment} { - if { $size > 0 } { - set x($var) [read $out $size] - } else { - set x($var) "" - } - } - set next_file [tell $out] - lappend report "file $i: $x(offset) $x(sizes) $x(filename)" - - seek $out [expr {$current_file+42}] - puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] - - #verify: - flush $out - seek $out $current_file - set fileheader [read $out 46] - lappend report "old $x(offset) + $stuboffset" - binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - lappend report "new $x(offset)" - - seek $out $next_file - } - } - - close $out - #pdict/showdict reuire punk & textlib - ie lots of dependencies - #don't fall over just because of that - catch { - punk::lib::showdict -roottype list -chan stderr $report - } - #puts [join $report \n] - return - } - - proc connect_if_not {{podpath ""}} { - upvar ::modpod::connected connected - set podpath [::modpod::system::normalize $podpath] - set docon 0 - if {![llength $connected(to)]} { - if {![string length $podpath]} { - error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" - } else { - set docon 1 - } - } else { - if {![string length $podpath]} { - set podpath [lindex $connected(to) end] - puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" - } else { - if {$podpath ni $connected(to)} { - set docon 1 - } - } - } - if {$docon} { - if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { - error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" - } else { - return $podpath - } - } - #we were already connected - return $podpath - } - - proc myversion {} { - upvar ::modpod::connected connected - set script [info script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" - } - set fname [file tail [file rootname [file normalize $script]]] - set scriptdir [file dirname $script] - - if {![string match "#modpod-*" $fname]} { - lassign [lrange [split $fname -] end-1 end] _pkgname version - } else { - lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version - if {![string length $version]} { - #try again on the name of the containing folder - lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version - #todo - proper walk up the directory tree - if {![string length $version]} { - #try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) - lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version - } - } - } - - #tarjar::Log debug "'myversion' determined version for [info script]: $version" - return $version - } - - proc myname {} { - upvar ::modpod::connected connected - set script [info script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" - } - return $connected(fullpackage,$script) - } - proc myfullname {} { - upvar ::modpod::connected connected - set script [info script] - #set script [::tarjar::normalize $script] - set script [file normalize $script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" - } - return $::tarjar::connected(fullpackage,$script) - } - proc normalize {path} { - #newer versions of Tcl don't do tilde sub - - #Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) - # we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. - set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. - set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after - set path [file normalize $path] - #set path [string tolower $path] ;#must do this after file normalize - return [string map [list $matilda ~] $path] ;#get our tildes back. -} -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide modpod [namespace eval modpod { - variable pkg modpod - variable version - set version 0.1.3 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/natsort-0.1.1.6.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/natsort-0.1.1.6.tm deleted file mode 100644 index 07c29895..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/natsort-0.1.1.6.tm +++ /dev/null @@ -1,1962 +0,0 @@ -#! /usr/bin/env tclsh - - -#todo - remove flagfilter - use punk::args? -package require flagfilter -namespace import ::flagfilter::check_flags - -namespace eval natsort { - #REVIEW - determine and document the purpose of scriptdir being added to tm path - proc scriptdir {} { - set possibly_linked_script [file dirname [file normalize [file join [info script] __dummy__]]] - if {[file isdirectory $possibly_linked_script]} { - return $possibly_linked_script - } else { - return [file dirname $possibly_linked_script] - } - } - if {![interp issafe]} { - set sdir [scriptdir] - #puts stderr "natsort tcl::tm::add $sdir" - if {$sdir ni [tcl::tm::list]} { - catch {tcl::tm::add $sdir} - } - } -} - - -namespace eval natsort { - variable stacktrace_on 0 - - proc do_error {msg {then error}} { - #note we exit or error out even if debug selected - as every do_error call is meant to interrupt code processing at the site of call - #this is not just a 'logging' call even though it has log-like descriptors - lassign $then type code - if {$code eq ""} { - set code 1 - } - set type [string tolower $type] - set levels [list debug info notice warn error critical] - if {$type in [concat $levels exit]} { - puts stderr "|$type> $msg" - } else { - puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be one of '$levels' or 'exit '" - } - flush stderr - if {$::tcl_interactive} { - #may not always be desirable - but assumed to be more useful not to exit despite request, to aid in debugging - if {[string tolower $type] eq "exit"} { - puts stderr " (exit suppressed due to tcl_interactive - raising error instead)" - if {![string is digit -strict $code]} { - puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be: 'exit '" - } - flush stderr - } - return -code error $msg - } else { - if {$type ne "exit"} { - return -code error $msg - } else { - if {[string is digit -strict $code]} { - exit $code - } else { - puts stderr "|>natsort_call_err> unable to interpret 2nd argument to do_error: '$then' should be 'error' or 'exit '" - return -code error $msg - } - } - } - } - - - - - - - variable debug 0 - variable testlist - set testlist { - 00.test-firstposition.txt - 0001.blah.txt - 1.test-sorts-after-all-leadingzero-number-one-equivs.txt - 1010.thousand-and-ten.second.txt - 01010.thousand-and-ten.first.txt - 0001.aaa.txt - 001.zzz.txt - 08.octal.txt-last-octal - 008.another-octal-first-octal.txt - 08.again-second-octal.txt - 001.a.txt - 0010.reconfig.txt - 010.etc.txt - 005.etc.01.txt - 005.Etc.02.txt - 005.123.abc.txt - 200.somewhere.txt - 2zzzz.before-somewhere.txt - 00222-after-somewhere.txt - 005.00010.abc.txt - 005.a3423bc.00010.abc.txt - 005.001.abc.txt - 005.etc.1010.txt - 005.etc.010.txt - 005.etc.10.txt - " 005.etc.10.txt" - 005.etc.001.txt - 20.somewhere.txt - 4611686018427387904999999999-bignum.txt - 4611686018427387903-bigishnum.txt - 9223372036854775807-bigint.txt - etca-a - etc-a - etc2-a - a0001blah.txt - a010.txt - winlike-sort-difference-0.1.txt - winlike-sort-difference-0.1.1.txt - a1.txt - b1-a0001blah.txt - b1-a010.txt - b1-a1.txt - -a1.txt - --a1.txt - --a10.txt - 2.high-two.yml - 02.higher-two.yml - reconfig.txt - _common.stuff.txt - CASETEST.txt - casetest.txt - something.txt - some~thing.txt - someathing.txt - someThing.txt - thing.txt - thing_revised.txt - thing-revised.txt - "thing revised.txt" - "spacetest.txt" - " spacetest.txt" - " spacetest.txt" - "spacetest2.txt" - "spacetest 2.txt" - "spacetest02.txt" - name.txt - name2.txt - "name .txt" - "name2 .txt" - blah.txt - combined.txt - a001.txt - .test - .ssh - "Feb 10.txt" - "Feb 8.txt" - 1ab23v23v3r89ad8a8a8a9d.txt - "Folder (10)/file.tar.gz" - "Folder/file.tar.gz" - "Folder (1)/file (1).tar.gz" - "Folder (1)/file.tar.gz" - "Folder (01)/file.tar.gz" - "Folder1/file.tar.gz" - "Folder(1)/file.tar.gz" - - } - lappend testlist "Some file.txt" - lappend testlist " Some extra file1.txt" - lappend testlist " Some extra file01.txt" - lappend testlist " some extra file1.txt" - lappend testlist " Some extra file003.txt" - lappend testlist " Some file.txt" - lappend testlist "Some extra file02.txt" - lappend testlist "Program Files (x86)" - lappend testlist "01999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999991-bigger-pathologically-bignum.txt" - lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt" - lappend testlist "29999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-smaller-pathologically-bignum.txt" - lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt with (more 1.txt" - lappend testlist "199999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999-pathologically-bignum.txt with (more 01.txt" - lappend testlist "a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1a1.pathological-num-nonnum-swapping-leadzero-should-be-first.txt" - lappend testlist "a1a1a1a1a1a1a1a1a1a1a1a01a1a1a1a1a1a1a1a1a1a1a1a1.pathological-num-nonnum-swapping-leadzero-should-be-first.txt" - lappend testlist "b1b1b1b1.txt" - lappend testlist "b1b01z1z1.txt" - lappend testlist "c1c111c1.txt" - lappend testlist "c1c1c1c1.txt" - - namespace eval overtype { - proc right {args} { - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? undertext overtext} - } - foreach {undertext overtext} [lrange $args end-1 end] break - - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set olen [string length $overtext] - set ulen [string length $undertext] - - if {$opt(-overflow)} { - return [string range $undertext 0 end-$olen]$overtext - } else { - if {$olen > $ulen} { - set diff [expr {$olen - $ulen}] - return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] - } else { - return [string range $undertext 0 end-$olen]$overtext - } - } - } - proc left {args} { - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - foreach {undertext overtext} [lrange $args end-1 end] break - - set opt(-ellipsis) 0 - set opt(-ellipsistext) {...} - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set len [string length $undertext] - set overlen [string length $overtext] - set diff [expr {$overlen - $len}] - - #puts stdout "====================>overtype: datalen:$len overlen:$overlen diff:$diff" - #puts stdout "====================>overtype: data: $overtext" - if {$diff > 0} { - if {$opt(-overflow)} { - return $overtext - } else { - if {$opt(-ellipsis)} { - return [overtype::left [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)] - } else { - return [string range $overtext 0 [expr {$len -1}]] - } - } - } else { - return "$overtext[string range $undertext $overlen end]" - } - } - - } - - #considered using hex to make large numbers more compact for viewing in debug output - but it's not that much shorter and probably obscures more than it helps. - proc hex2dec {largeHex} { - #todo - use punk::lib::hex2dec - (scan supports ll so can do larger hex values directly) - set res 0 - set largeHex [string map {_ {}} $largeHex] - if {[string length $largeHex] <=7} { - #scan can process up to FFFFFFF and does so quickly - return [scan $largeHex %x] - } - foreach hexDigit [split $largeHex {}] { - set new 0x$hexDigit - set res [expr {16*$res + $new}] - } - return $res - } - proc dec2hex {decimalNumber} { - format %4.4llX $decimalNumber - } - - #punk::lib::trimzero - proc trimzero {number} { - set trimmed [string trimleft $number 0] - if {[string length $trimmed] == 0} { - set trimmed 0 - } - return $trimmed - } - #todo - consider human numeric split - #e.g consider SI suffixes k|KMGTPEZY in that order - - #in this context, for natural sorting - numeric segments don't contain underscores or other punctuation such as . - + etc. - #review - what about unicode equivalents such as wide numerals \UFF10 to \UFF19? unicode normalization? - proc split_numeric_segments {name} { - set segments [list] - while {[string length $name]} { - if {[scan $name {%[0-9]%n} chunk len] == 2} { - lappend segments $chunk - set name [string range $name $len end] - } - if {[scan $name {%[^0-9]%n} chunk len] == 2} { - lappend segments $chunk - set name [string range $name $len end] - } - } - return $segments - } - - proc padleft {str count {ch " "}} { - set val [string repeat $ch $count] - append val $str - set diff [expr {max(0,$count - [string length $str])}] - set offset [expr {max(0,$count - $diff)}] - set val [string range $val $offset end] - } - - - # Sqlite may have limited collation sequences available in default builds. - # with custom builds - there may be others such as 'natsort' - see https://sqlite.org/forum/forumpost/e4dc6f3331 - # This is of limited use with the few builtin collations available in 2023 ie binary,nocase & rtrim - # but may provide a quicker,flexible sort option, especially if/when more collation sequences are added to sqlite - # There are also prebuilt packages such as sqlite3-icu which allows things like "SELECT icu_load_collation('en_AU', 'australian');" - proc sort_sqlite {stringlist args} { - package require sqlite3 - - - set args [check_flags -caller natsort_sqlite -defaults [list -db :memory: -collate nocase -winlike 0 -topchars "\uFFFF" -debug 0 -splitchars [list / . - _] -extras {all}] -values $args] - set db [string trim [dict get $args -db]] - set collate [string trim [dict get $args -collate]] - set debug [string trim [dict get $args -debug]] - set topchars [string trim [dict get $args -topchars]] - - set topdot [expr {"." in $topchars}] - set topunderscore [expr {"_" in $topchars}] - - - sqlite3 db_sort_basic $db - set orderedlist [list] - db_sort_basic eval [string map [list %collate% $collate] {create table sqlitesort(index0 text COLLATE %collate%, name text COLLATE %collate%)}] - foreach nm $stringlist { - set segments [split_numeric_segments $nm] - set index "" - set s 0 - foreach seg $segments { - if {($s == 0) && ![string length [string trim $seg]]} { - #don't index leading space - } elseif {($s == 0) && ($topunderscore) && [string match _* [string trim $seg]]} { - append index "[padleft "0" 5]-d -100 topunderscore " - append index [string trim $seg] - } elseif {($s == 0) && ($topdot) && [string match .* [string trim $seg]]} { - append index "[padleft "0" 5]-d -50 topdot " - append index [string trim $seg] - } else { - if {[string is digit [string trim $seg]]} { - set basenum [trimzero [string trim $seg]] - set lengthindex "[padleft [string length $basenum] 5]-d" - append index "$lengthindex " - #append index [padleft $basenum 40] - append index $basenum - } else { - append index [string trim $seg] - } - } - incr s - } - puts stdout ">>$index" - db_sort_basic eval {insert into sqlitesort values($index,$nm)} - } - db_sort_basic eval [string map [list %collate% $collate] {select name from sqlitesort order by index0 COLLATE %collate% ASC, name COLLATE %collate% ASC }] { - lappend orderedlist $name - } - db_sort_basic close - return $orderedlist - } - - proc get_leading_char_count {str char} { - #todo - something more elegant? regex? - set count 0 - foreach c [split $str "" ] { - if {$c eq $char} { - incr count - } else { - break - } - } - return $count - } - proc stacktrace {} { - set stack "Stack trace:\n" - for {set i 1} {$i < [info level]} {incr i} { - set lvl [info level -$i] - set pname [lindex $lvl 0] - append stack [string repeat " " $i]$pname - - if {![catch {info args $pname} pargs]} { - foreach value [lrange $lvl 1 end] arg $pargs { - - if {$value eq ""} { - if {$arg != 0} { - info default $pname $arg value - } - } - append stack " $arg='$value'" - } - } else { - append stack " !unknown vars for $pname" - } - - append stack \n - } - return $stack - } - - proc get_char_count {str char} { - #faster than lsearch on split for str of a few K - expr {[tcl::string::length $str]-[tcl::string::length [tcl::string::map "$char {}" $str]]} - } - - proc build_key {chunk splitchars topdict tagconfig debug} { - variable stacktrace_on - if {$stacktrace_on} { - puts stderr "+++>[stacktrace]" - } - - set index_map [list - "" _ ""] - #e.g - need to maintain the order - #a b.txt - #a book.txt - #ab.txt - #abacus.txt - - - set original_splitchars [dict get $tagconfig original_splitchars] - - # tag_dashes test moved from loop - review - set tag_dashes 0 - if {![string length [dict get $tagconfig last_part_text_tag]]} { - #winlike - set tag_dashes 1 - } - if {("-" ni $original_splitchars)} { - set tag_dashes 1 - } - if {$debug >= 3} { - puts stdout "START build_key chunk : $chunk" - puts stdout "START build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" - } - - - ## index_map will have no effect if we've already split on the char anyway(?) - #foreach m [dict keys $index_map] { - # if {$m in $original_splitchars} { - # dict unset index_map $m - # } - #} - - #if {![string length $chunk]} return - - set result "" - if {![llength $splitchars]} { - #no more structural splits - but we need to examine numeric/non-numeric segments at the lowest level. - # we are at a leaf in the recursive split hierarchy - - set s "" ;#we never actually split on "" (unless that was put in splitchars.. but it probably shouldn't be) - set parts [list $chunk] ;#important to treat as list or leading/trailing whitespace lost - - - } else { - set s [lindex $splitchars 0] - if {"spudbucket$s" in "[split $chunk {}]"} { - error "dead-branch spudbucket" - set partindex [build_key $chunk [lrange $splitchars 1 end] $topdict $tagconfig $debug] - if {[dict get $tagconfig showsplits]} { - set pfx "(1${s}=)" ;# = sorts before _ - set partindex ${pfx}$partindex - } - - return $partindex - } else { - set parts_below_index "" - - if {$s ni [split $chunk ""]} { - #$s can be an empty string - set parts [list $chunk] - } else { - set parts [split $chunk $s] ;#whitespace preserved - even if splitting on s that is not in string. - } - #assert - we have a splitchar $s that is in the chunk - so at least one part - if {(![string length $s] || [llength $parts] == 0)} { - error "buld_key assertion false empty split char and/or no parts" - } - - set pnum 1 ;# 1 based for clarity of reading index in debug output - set subpart_count [llength $parts] - - set sub_splits [lrange $splitchars 1 end] ;#pass same splitchars to each subpart - foreach p $parts { - set partindex [build_key $p $sub_splits $topdict $tagconfig $debug] - set lastpart [expr {$pnum == $subpart_count}] - - - ####################### - set showsplits [dict get $tagconfig showsplits] - #split prefixing experiment - maybe not suitable for general use - as it affects sort order - #note that pfx must be consistent until last one, no matter how many partnumbers there are in total. - # we don't want to influence sort order before reaching end. - #e.g for: - #(1.=)... - #(1._)...(2._)...(3.=) - #(1._)...(2.=) - #Note that this is probably more suitable for highly structure dependant sorts where the results are maybe less.. natural. - if {$showsplits} { - if {$lastpart} { - set pfx "(${pnum}${s}_" - #set pfx "(${pnum}${s}=)" ;# = sorts before _ - } else { - set pfx "(${pnum}${s}_" - } - append parts_below_index $pfx - } - ####################### - - if {$lastpart} { - if {[string length $p] && [string is digit $p]} { - set last_part_tag "<22${s}>" - } else { - set last_part_tag "<33${s}>" - } - - set last_part_text_tag [dict get $tagconfig last_part_text_tag] - #for -winlike 1 there is no tag configured. Windows explorer likes to put things in the order: - # module-0.1.1.tm - # module-0.1.1.2.tm - # module-0.1.tm - # arguably -winlike 0 is more natural/human - # module-0.1.tm - # module-0.1.1.tm - # module-0.1.1.2.tm - - if {[string length $last_part_text_tag]} { - #replace only the first text-tag (<30>) from the subpart_index - if {[string match "<30?>*" $partindex]} { - #give textual string index a specific tag for last part in split only. e.g <130> for lower than integers - set partindex "<130>[string range $partindex 5 end]" - } - #append parts_below_index $last_part_tag - } - #set partindex $last_part_tag$partindex - - - } - append parts_below_index $partindex - - - - if {$showsplits} { - if {$lastpart} { - set suffix "${pnum}${s}=)" ;# = sorts before _ - } else { - set suffix "${pnum}${s}_)" - } - append parts_below_index $suffix - } - - - incr pnum - } - append parts_below_index "" ;# don't add anything at the tail that may perturb sort order - - if {$debug >= 3} { - set pad [string repeat " " 20] - puts stdout "END build_key chunk : $chunk " - puts stdout "END build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" - puts stdout "END build_key ret below_index: $parts_below_index" - } - return $parts_below_index - - - } - } - - - - #puts stdout ">>>chunk:'$chunk'<<< split-on:$s parts: '$parts' splitchars: $splitchars -topdict:$topdict" - - - - - - #if {$chunk eq ""} { - # puts "___________________________________________!!!____" - #} - #puts stdout "-->chunk:$chunk $s parts:$parts" - - #puts stdout "---chunk:'$chunk' part:'$part' parts:'$parts' s:'$s'" - - - - - set segments [split_numeric_segments $chunk] ;#! - set stringindex "" - set segnum 0 - foreach seg $segments { - #puts stdout "=================---->seg:$seg segments:$segments" - #-strict ? - if {[string length $seg] && [string is digit $seg]} { - set basenum [trimzero [string trim $seg]] - set lengthindex "[padleft [string length $basenum] 4]d" - #append stringindex "<20>$lengthindex $basenum $seg" - } else { - set c1 [string range $seg 0 0] - #puts stdout "==============> c1'$c1' topdict: $topdict stringindex:$stringindex" - - if {$c1 in [dict keys $topdict]} { - set tag [dict get $topdict $c1] - #append stringindex "${tag}$c1" - #set seg [string range $seg 1 end] - } - #textindex - set leader "<30>" - set idx $seg - set idx [string trim $idx] - set idx [string tolower $idx] - set idx [string map $index_map $idx] - - - - - - #set the X-c count to match the length of the index - not the raw data - set lengthindex "[padleft [string length $idx] 4]c" - - #append stringindex "${leader}$idx $lengthindex $texttail" - } - } - - if {[llength $parts] != 1} { - error "build_key assertion fail llength parts != 1 parts:$parts" - } - - set segtail_clearance_buffer " " ;#space to clear other split indicators if using showsplits - set segtail $segtail_clearance_buffer - append segtail "\[" - set grouping "" - set pnum 0 - foreach p $parts { - set sublen_list [list] - set subsegments [split_numeric_segments $p] - set i 0 - - set partsorter "" - foreach sub $subsegments { - ##don't trim spaces here - it would be inconsistent. Some subs are pure whitespace - others have internal whitespace. e.g "a4 400b a b2" becomes "a 4 { } 400 {b a b} 2" - #mapping away all whitespace would be consistent, but not necessarily desirable. If it's in the index_map it'll happen anyway - so we don't do it manually here except for evaluating conditions. - set test_trim [string trim $sub] - set str $sub - set str [string tolower $str] - set str [string map $index_map $str] - if {[string length $test_trim] && [string is digit $test_trim]} { - append partsorter [trimzero $str] - } else { - append partsorter "$str" - } - append partsorter - } - - - foreach sub $subsegments { - - if {[string length $sub] && [string is digit $sub]} { - set basenum [trimzero [string trim $sub]] - set subequivs $basenum - set lengthindex "[padleft [string length $subequivs] 4]d " - set idx "$lengthindex [padleft $basenum 10]" ;#todo - cycle through data and determine longest - set tail [overtype::left [string repeat " " 10] $sub] - #set tail "" - } else { - set idx "" - - - set lookahead [lindex $subsegments $i+1] - if {![string length $lookahead]} { - set zeronum "[padleft 0 4]d0" - } else { - set zeronum "" - } - set subequivs $sub - #set subequivs [string trim $subequivs] - set subequivs [string tolower $subequivs] - set subequivs [string map $index_map $subequivs] - - append idx $subequivs - append idx $zeronum - - set idx $subequivs - - - # - - set ch "-" - if {$tag_dashes} { - #puts stdout "____TAG DASHES" - #winlike - set numleading [get_leading_char_count $seg $ch] - if {$numleading > 0} { - set texttail "<31-leading[padleft $numleading 4]$ch>" - } else { - set texttail "<30>" - } - set numothers [expr {[get_char_count $seg $ch] - $numleading}] - if {$debug >= 2} { - puts stdout "____dashcount: [get_char_count $seg $ch] numothers: $numothers" - } - if {$numothers > 0} { - append texttail "<31-others[padleft $numothers 4]$ch>" - } else { - append textail "<30>" - } - } else { - set texttail "<30>" - } - - - - - #set idx $partsorter - set tail "" - #set tail [string tolower $sub] ;#raw - #set tail $partsorter - #append tail ":[string tolower $p]" ;#we need the whole part - even though it makes the index much larger. !todo - tagconfig switch to toggle case sensitive sorting - } - - append grouping "$idx $tail|$s" - incr i - } - - - - - - if {$p eq ""} { - # no subsegments.. - set zeronum "[padleft 0 4]d0" - #append grouping "\u000$zerotail" - append grouping ".$zeronum" - } - - #append grouping | - #append grouping $s - #foreach len $sublen_list { - # append segtail "<[padleft $len 3]>" - #} - incr pnum - } - set grouping [string trimright $grouping $s] - append grouping "[padleft [llength $parts] 4]" - append segtail $grouping - - - #append segtail " <[padleft [llength $parts] 4]>" - - append segtail "\]" - - - #if {[string length $seg] && [string is digit $seg]} { - # append segtail "<20>" - #} else { - # append segtail "<30>" - #} - append stringindex $segtail - - incr segnum - - - - - lappend indices $stringindex - - if {[llength $indices] > 1} { - puts stderr "INDICES [llength $indices]: $stringindex" - error "build_key assertion error deadconcept indices" - } - - #topchar handling on splitter characters - #set c1 [string range $chunk 0 0] - if {$s in [dict keys $topdict]} { - set tag [dict get $topdict $s] - set joiner [string map [list ">" "$s>"] ${tag}] - #we have split on this character $s so if the first part is empty string then $s was a leading character - # we need to bring a tag out front for this, or it will be dominated by the leading sections-remaing tag - # (since the empty string produces no tag of it's own - ?) - if {[string length [lindex $parts 0]] == 0} { - set prefix ${joiner} - } else { - set prefix "" - } - } else { - #use standard character-data positioning tag if no override from topdict - set joiner "<30J>$s" - set prefix "" - } - - - set contentindex $prefix[join $indices $joiner] - if {[string length $s]} { - set split_indicator "" - } else { - set split_indicator "" - - } - if {![string length $s]} { - set s ~ - } - - #return "[overtype::left [string repeat { } 80] $contentindex][overtype::left [string repeat { } 10] [list $s $chunk]]" - #return $contentindex$split_indicator - #return [overtype::left [string repeat - 40] $contentindex] - - if {$debug >= 3} { - puts stdout "END build_key chunk : $chunk" - puts stdout "END build_key splitchars : $splitchars $topdict $tagconfig NO tag dashes" - puts stdout "END build_key ret contentidx : $contentindex" - } - return $contentindex - } - - #---------------------------------------- - #line-processors - data always last argument - opts can be empty string - #all processor should accept empty opts and ignore opts if they don't use them - proc _lineinput_as_tcl1 {opts line} { - set out "" - foreach i $line { - append out "$i " - } - set out [string range $out 0 end-1] - return $out - } - #should be equivalent to above - proc _lineinput_as_tcl {opts line} { - return [concat {*}$line] - } - #will put extra tcl quoting if it was already tcl-shaped e.g text "a" -> {"a"} - proc _lineoutput_as_tcl {opts line} { - return [regexp -inline -all {\S+} $line] - } - - proc _lineinput_as_raw {opts line} { - return $line - } - proc _lineoutput_as_raw {opts line} { - return $line - } - - #words is opposite of tcl - proc _lineinput_as_words {opts line} { - #wordlike_parts - return [regexp -inline -all {\S+} $line] - } - proc _lineoutput_as_words {opts line} { - return [concat {*}$line] - } - - #opts same as tcllib csv::split - except without the 'line' element - #?-alternate? ?sepChar? ?delChar? - proc _lineinput_as_csv {opts line} { - package require csv - if {[lindex $opts 0] eq "-alternate"} { - return [csv::split -alternate $line {*}[lrange $opts 1 end]] - } else { - return [csv::split $line {*}$opts] - } - } - #opts same as tcllib csv::join - #?sepChar? ?delChar? ?delMode? - proc _lineoutput_as_csv {opts line} { - package require csv - return [csv::join $line {*}$opts] - } - #---------------------------------------- - variable sort_flagspecs - set sort_flagspecs [dict create\ - -caller natsort::sort \ - -return supplied|defaults \ - -defaults [list -collate nocase \ - -winlike 0 \ - -splits "\uFFFF" \ - -topchars {. _} \ - -showsplits 1 \ - -sortmethod ascii \ - -collate "\uFFFF" \ - -inputformat raw \ - -inputformatapply {index data} \ - -inputformatoptions "" \ - -outputformat raw \ - -outputformatoptions "" \ - -cols "\uFFFF" \ - -debug 0 -db "" -stacktrace 0 -splits "\uFFFF" -showsplits 0] \ - -required {all} \ - -extras {none} \ - -commandprocessors {}\ - ] - - proc sort {stringlist args} { - #puts stdout "natsort::sort args: $args" - variable debug - variable sort_flagspecs - if {![llength $stringlist]} return - if {[llength $stringlist] == 1} { - if {"-inputformat" ni $args && "-outputformat" ni $args} { - return $stringlist - } - } - - #allow pass through of the check_flags flag -debugargs so it can be set by the caller - set debugargs 0 - if {[set posn [lsearch $args -debugargs]] >=0} { - if {$posn == [llength $args]-1} { - #-debugargs at tail of list - set debugargs 1 - } else { - set debugargs [lindex $args $posn+1] - } - } - - #-return flagged|defaults doesn't work Review. - #flagfilter global processor/allocator not working 2023-08 - - set opts [check_flags {*}$sort_flagspecs -debugargs $debugargs -values $args] - - #we can only shortcircuit input list of single element at this point if there aren't non-default -inputformat or -outputformat transformations - if {[llength $stringlist] == 1} { - set is_basic 1 - foreach fname [list -inputformat -outputformat] { - if {[dict get $sort_flagspecs -defaults $fname] ne [dict get $opts $fname]} { - set is_basic 0 - break - } - } - if {$is_basic} { - return $stringlist - } - } - - - set winlike [dict get $opts -winlike] - set topchars [dict get $opts -topchars] - set cols [dict get $opts -cols] - set debug [dict get $opts -debug] - set stacktrace [dict get $opts -stacktrace] - set showsplits [dict get $opts -showsplits] - set splits [dict get $opts -splits] - set sortmethod [dict get $opts -sortmethod] - set opt_collate [dict get $opts -collate] - set opt_inputformat [dict get $opts -inputformat] - set opt_inputformatapply [dict get $opts -inputformatapply] - set opt_inputformatoptions [dict get $opts -inputformatoptions] - set opt_outputformat [dict get $opts -outputformat] - set opt_outputformatoptions [dict get $opts -outputformatoptions] - - if {$debug} { - #dict unset opts -showsplits - #dict unset opts -splits - puts stdout "natsort::sort processed_args: $opts" - if {$debug == 1} { - puts stdout "natsort::sort - try also -debug 2, -debug 3" - } - } - - #set sortmethod "-dictionary" ;# sorts a2b before a001b - possibly other strangenesses that are hard to reason about - switch -- $sortmethod { - dictionary - ascii { - set sortmethod "-$sortmethod" - # -ascii is default for tcl lsort. - } - default { - set sortmethod "-ascii" - } - } - - set allowed_collations [list nocase] - if {$opt_collate ne "\uFFFF"} { - if {$opt_collate ni $allowed_collations} { - error "natsort::sort unknown value for -collate option. Only acceptable value(s): $allowed_collations" - } - set nocaseopt "-$opt_collate" - } else { - set nocaseopt "" - } - set allowed_inputformats [list tcl raw csv words] - switch -- $opt_inputformat { - tcl - raw - csv - words {} - default { - error "natsort::sort unknown value for -inputformat option. Only acceptable value(s): $allowed_inputformats" - } - } - set allowed_outputformats [list tcl raw csv words] - switch -- $opt_outputformat { - tcl - raw - csv - words {} - default { - error "natsort::sort unknown value for -outputformat option. Only acceptable value(s): $allowed_outputformats" - } - } - - # - set winsplits [list / . _] - set commonsplits [list / . _ -] - #set commonsplits [list] - - set tagconfig [dict create] - dict set tagconfig last_part_text_tag "<19>" - if {$winlike} { - set splitchars $winsplits - #windows explorer sorts leading spaces at the top - which doesn't seem very helpful for keeping things together - but the explorer doesn't seem able to create leading spaces anyway. - set wintop [list "(" ")" { } {.} {_}] ;#windows specific order - foreach t $topchars { - if {$t ni $wintop} { - lappend wintop $t - } - } - set topchars $wintop - dict set tagconfig last_part_text_tag "" - } else { - set splitchars $commonsplits - } - if {$splits ne "\uFFFF"} { - set splitchars $splits - } - dict set tagconfig original_splitchars $splitchars - dict set tagconfig showsplits $showsplits - - #create topdict - set i 0 - set topdict [dict create] - foreach c $topchars { - incr i ;#start at 01 so that 00 reserved for final-split tag (allows x-0.1.txt to sort above x-0.1.1.txt by default. Use tagconfig to change, or choose -winlike 1 for explorer-like sorting) - dict set topdict $c "<0$i>" - } - set keylist [list] - - switch -- $opt_inputformat { - tcl { - set lineinput_transform [list _lineinput_as_tcl $opt_inputformatoptions] - } - csv { - set lineinput_transform [list _lineinput_as_csv $opt_inputformatoptions] - } - raw { - set lineinput_transform [list _lineinput_as_raw $opt_inputformatoptions] - } - words { - set lineinput_transform [list _lineinput_as_words $opt_inputformatoptions] - } - } - switch -- $opt_outputformat { - tcl { - set lineoutput_transform [list _lineoutput_as_tcl $opt_outputformatoptions] - } - csv { - set lineoutput_transform [list _lineoutput_as_csv $opt_outputformatoptions] - } - raw { - set lineoutput_transform [list _lineoutput_as_raw $opt_outputformatoptions] - } - words { - set lineoutput_transform [list _lineoutput_as_words $opt_outputformatoptions] - } - } - - if {("data" in $opt_inputformatapply) || ("index" in $opt_inputformatapply)} { - if {$opt_inputformat eq "raw"} { - set tf_stringlist $stringlist - } else { - set tf_stringlist [list] - foreach v $stringlist { - lappend tf_stringlist [{*}$lineinput_transform $v] - } - } - if {"data" in $opt_inputformatapply} { - set tf_data_stringlist $tf_stringlist - } else { - set tf_data_stringlist $stringlist - } - if {"index" in $opt_inputformatapply} { - set tf_index_stringlist $tf_stringlist - } else { - set tf_index_stringlist $stringlist - } - } else { - set tf_data_stringlist $stringlist - set tf_index_stringlist $stringlist - } - - - - if {$stacktrace} { - puts stdout [natsort::stacktrace] - set natsort::stacktrace_on 1 - } - if {$cols eq "\uFFFF"} { - set colkeys [lmap v $stringlist {}] - } else { - set colkeys [list] - foreach v $tf_index_stringlist { - set lineparts $v - set k [list] - foreach c $cols { - lappend k [lindex $lineparts $c] - } - lappend colkeys [join $k "_"] ;#use a common-split char - Review - } - } - #puts stdout "colkeys: $colkeys" - - if {$opt_inputformat eq "raw"} { - #no inputformat was applied - can just use stringlist - foreach value $stringlist ck $colkeys { - set contentindex [build_key $value $splitchars $topdict $tagconfig $debug] - set colindex [build_key $ck $splitchars $topdict $tagconfig $debug] - lappend keylist ${colindex}-${contentindex}-$value ;#note: entire raw value used for final sort disambiguation (can be whitespace that was ignored in indexing) - } - } else { - foreach keyinput $tf_index_stringlist datavalue $tf_data_stringlist ck $colkeys { - #data may or may not have been transformed - #column index may or may not have been built with transformed data - - set contentindex [build_key $keyinput $splitchars $topdict $tagconfig $debug] - set colindex [build_key $ck $splitchars $topdict $tagconfig $debug] - lappend keylist ${colindex}-${contentindex}-$datavalue ;#note: entire value used for final sort disambiguation (can be whitespace that was ignored in indexing) - } - } - #puts stderr "keylist: $keylist" - - ################################################################################################### - # Use the generated keylist to do the actual sorting - # select either the transformed or raw data as the corresponding output - ################################################################################################### - if {[string length $nocaseopt]} { - set sortcommand [list lsort $sortmethod $nocaseopt -indices $keylist] - } else { - set sortcommand [list lsort $sortmethod -indices $keylist] - } - if {$opt_outputformat eq "raw"} { - #raw output means no further transformations - it doesn't mean there wasn't a transform applied on the input side - #use the tf_data_stringlist in the output - which will be the same as the input stringlist if no input transform applied for data. - #(Also - it may or may not have been *sorted* on transformed data depending on whether 'index' was in $opt_inputformatapply) - foreach idx [{*}$sortcommand] { - lappend result [lindex $tf_data_stringlist $idx] - } - } else { - #we need to apply an output format - #The data may or may not have been transformed at input - foreach idx [{*}$sortcommand] { - lappend result [{*}$lineoutput_transform [lindex $tf_data_stringlist $idx]] - } - } - ################################################################################################### - - - - - - if {$debug >= 2} { - set screen_width 250 - set max_val 0 - set max_idx 0 - ##### calculate colum widths - foreach i [{*}$sortcommand] { - set len_val [string length [lindex $stringlist $i]] - if {$len_val > $max_val} { - set max_val $len_val - } - set len_idx [string length [lindex $keylist $i]] - if {$len_idx > $max_idx} { - set max_idx $len_idx - } - } - #### - set l_width [expr {$max_val + 1}] - set leftcol [string repeat " " $l_width] - set r_width [expr {$screen_width - $l_width - 1}] - set rightcol [string repeat " " $r_width] - set str [overtype::left $leftcol RAW] - puts stdout " $str Index with possibly transformed data at tail" - foreach i [{*}$sortcommand] { - #puts stdout "|d> [overtype::left $leftcol [lindex $stringlist $i] ] [lindex $keylist $i]" - set index [lindex $keylist $i] - set len_idx [string length $index] - set rowcount [expr {$len_idx / $r_width}] - if {($len_idx % $r_width) > 0} { - incr rowcount - } - set rows [list] - for {set r 0} {$r < $rowcount} {incr r} { - lappend rows [string range $index 0 $r_width-$r] - set index [string range $index $r_width end] - } - - set r 0 - foreach idxpart $rows { - if {$r == 0} { - #use the untransformed stringlist - set str [overtype::left $leftcol [lindex $stringlist $i]] - } else { - set str [overtype::left $leftcol ...]] - } - puts stdout " $str $idxpart" - incr r - } - #puts stdout "|> '[lindex $stringlist $i]'" - #puts stdout "|> [lindex $keylist $i]" - } - - puts stdout "|debug> topdict: $topdict" - puts stdout "|debug> splitchars: $splitchars" - } - return $result - } - - - - #Note that although leading whitespace isn't a commonly used feature of filesystem names - it's possible at least on FreeBSD,windows and linux so we should try to handle it sensibly. - proc sort_experiment {stringlist args} { - package require sqlite3 - - variable debug - set args [check_flags -caller natsort::sort \ - -defaults [dict create -db :memory: -collate nocase -nullvalue "->NULL<" -winlike 0 -topchars [list] -debug 0] \ - -extras {all} \ - -values $args] - set db [string trim [dict get $args -db]] - set collate [string trim [dict get $args -collate]] - set winlike [string trim [dict get $args -winlike]] - set debug [string trim [dict get $args -debug]] - set nullvalue [string trim [dict get $args -nullvalue]] - - - set topchars [string trim [dict get $args -topchars]] - - set topdot [expr {"." in $topchars}] - set topunderscore [expr {"_" in $topchars}] - - - sqlite3 db_natsort2 $db - #-- - #our table must handle the name with the greatest number of numeric/non-numeric splits. - #This means a single list member with pathological naming e.g a1a1a1a1a1a1a1a1a1a1a1.txt could greatly extend the number of columns and indices and affect performance. - #review: could be optimised to aggregate the tail into a single index, as the the extra columns won't assist in ordering, but make the table and query bigger. - # we should probably determine the longest common sequence of splits in the input list and add only one more index for the segment after that. - set maxsegments 0 - #-- - set prefix "idx" - - #note - there will be more columns in the sorting table than segments. - # (a segment equals one of the numeric & non-numeric string portions returned from 'split_numeric_sgements') - #--------------------------- - # consider - # a123b.v1.2.txt - # a123b.v1.3beta1.txt - # these have the following segments: - # a 123 b.v 1 . 2 .txt - # a 123 b.v 1 . 3 beta 1 .txt - #--------------------------- - # The first string has 7 segments (numbered 0 to 6) - # the second string has 9 segments - # - # for example when the data has any elements in a segment position that are numeric (e.g 0001 123) - # - then an index column with numeric equivalents will be created (e.g 0001 becomes 1), and any non-numeric values in that column will get mapped to a negative value (for special cases) or a high value such as NULL (with NULLS LAST sql support) - # - # when a segment - - #cycle through all strings - we cannot build tabledef as we go because the column type depends on whether all segments for a particular column are text vs int-equivalent. - array set segmentinfo {} - foreach nm $stringlist { - set segments [split_numeric_segments $nm] - if {![string length [string trim [lindex $segments 0]]]} { - if {[string is digit [string trim [lindex $segments 1]]]} { - #name is whitespace followed by a digit - special case - ignore the whitespace for numbers only. (whitespace still goes through to name column though) - set segments [lrange $segments 1 end] - } - } - - - set c 0 ;#start of index columns - if {[llength $segments] > $maxsegments} { - set maxsegments [llength $segments] - } - foreach seg $segments { - set seg [string trim $seg] - set column_exists [info exists segmentinfo($c,type)] - if {[string is digit $seg]} { - if {$column_exists} { - #override it (may currently be text or int) - set segmentinfo($c,type) "int" - } else { - #new column - set segmentinfo($c,name) ${prefix}$c - set segmentinfo($c,type) "int" - } - } else { - #text never overrides int - if {!$column_exists} { - set segmentinfo($c,name) ${prefix}$c - set segmentinfo($c,type) "text" - } - } - incr c - } - } - if {$debug} { - puts stdout "Largest number of num/non-num segments in data: $maxsegments" - #parray segmentinfo - } - - # - set tabledef "" - set ordered_column_names [list] - set ordered_segmentinfo_tags [lsort -dictionary [array names segmentinfo *]] - foreach k $ordered_segmentinfo_tags { - lassign [split $k ,] c tag - if {$tag eq "type"} { - set type [set segmentinfo($k)] - if {$type eq "int"} { - append tabledef "$segmentinfo($c,name) int," - } else { - append tabledef "$segmentinfo($c,name) text COLLATE $collate," - } - append tabledef "raw$c text COLLATE $collate," - lappend ordered_column_names $segmentinfo($c,name) - lappend ordered_column_names raw$c ;#additional index column not in segmentinfo - } - if {$tag eq "name"} { - #lappend ordered_column_names $segmentinfo($k) - } - } - append tabledef "name text" - - #puts stdout "tabledef:$tabledef" - - - db_natsort2 eval [string map [list %tabledef% $tabledef] {create table natsort(%tabledef%)}] - - - foreach nm $stringlist { - array unset intdata - array set intdata {} - array set rawdata {} - #init array and build sql values string - set sql_insert "insert into natsort values(" - for {set i 0} {$i < $maxsegments} {incr i} { - set intdata($i) "" - set rawdata($i) "" - append sql_insert "\$intdata($i),\$rawdata($i)," - } - append sql_insert "\$nm" ;#don't manipulate name value in any way - e.g must leave all whitespace as the sort must return exactly the same elements as in the original list. - append sql_insert ")" - - set segments [split_numeric_segments $nm] - if {![string length [string trim [lindex $segments 0]]]} { - if {[string is digit [string trim [lindex $segments 1]]]} { - #name is whitespace followed by a digit - special case - ignore the whitespace for numbers only. (whitespace still goes through to name column though) - set segments [lrange $segments 1 end] - } - } - set values "" - set c 0 - foreach seg $segments { - if {[set segmentinfo($c,type)] eq "int"} { - if {[string is digit [string trim $seg]]} { - set intdata($c) [trimzero [string trim $seg]] - } else { - catch {unset intdata($c)} ;#set NULL - sorts last - if {($c == 0) && ($topunderscore) && [string match _* [string trim $seg]]} { - set intdata($c) -100 - } - if {($c == 0) && ($topdot) && [string match .* [string trim $seg]]} { - set intdata($c) -50 - } - } - set rawdata($c) [string trim $seg] - } else { - #pure text column - #set intdata($c) [string trim $seg] ;#ignore leading/trailing whitespace - we sort first on trimmed version, then refine with the sort on rawdata index - #catch {unset indata($c)} - set indata($c) [string trim $seg] - set rawdata($c) $seg - } - #set rawdata($c) [string trim $seg]# - #set rawdata($c) $seg - incr c - } - db_natsort2 eval $sql_insert - } - - set orderedlist [list] - - if {$debug} { - db_natsort2 eval {select * from pragma_table_info('natsort')} rowdata { - parray rowdata - } - } - set orderby "order by " - - foreach cname $ordered_column_names { - if {[string match "idx*" $cname]} { - append orderby "$cname ASC NULLS LAST," - } else { - append orderby "$cname ASC," - } - } - append orderby " name ASC" - #append orderby " NULLS LAST" ;#?? - - #e.g "order by idx0 ASC, raw0 ASC, idx1 ASC .... name ASC" - if {$debug} { - puts stdout "orderby clause: $orderby" - } - db_natsort2 eval [string map [list %orderby% $orderby] {select * from natsort %orderby%}] rowdata { - set line "- " - #parray rowdata - set columnnames $rowdata(*) - #puts stdout "columnnames: $columnnames" - #[lsort -dictionary [array names rowdata] - append line "$rowdata(name) \n" - foreach nm $columnnames { - if {$nm ne "name"} { - append line "$nm: $rowdata($nm) " - } - } - #puts stdout $line - #puts stdout "$rowdata(name)" - lappend orderedlist $rowdata(name) - } - - db_natsort2 close - return $orderedlist - } -} - - -#application section e.g this file might be linked from /usr/local/bin/natsort -namespace eval natsort { - namespace import ::flagfilter::check_flags - - proc called_directly_namematch {} { - global argv0 - if {[info script] eq ""} { - return 0 - } - #see https://wiki.tcl-lang.org/page/main+script - #trailing ... let's us resolve symlinks in last component of the path (could be something else like ___ but ... seems unlikely to collide with anything in the filesystem) - if {[info exists argv0] - && - [file dirname [file normalize [file join [info script] ...]]] - eq - [file dirname [file normalize [file join $argv0 ...]]] - } { - return 1 - } else { - #puts stdout "norm info script: [file dirname [file normalize [file join [info script] ...]]]" - #puts stdout "norm argv0 : [file dirname [file normalize [file join $argv0 ...]]]" - return 0 - } - } - #Review issues around comparing names vs using inodes (esp with respect to samba shares) - proc called_directly_inodematch {} { - global argv0 - - if {[info exists argv0] - && [file exists [info script]] && [file exists $argv0]} { - file stat $argv0 argv0Info - file stat [info script] scriptInfo - if {$argv0Info(ino) == 0 || $scriptInfo(ino) == 0 || $argv0Info(dev) == 0 || $scriptInfo(dev) == 0} { - #vfs? - #e.g //zipfs:/ - return 0 - } - return [expr {$argv0Info(dev) == $scriptInfo(dev) - && $argv0Info(ino) == $scriptInfo(ino)}] - } else { - return 0 - } - } - - if {![interp issafe]} { - set is_namematch [called_directly_namematch] - set is_inodematch [called_directly_inodematch] - #### - #review - reliability of mechanisms to determine direct calls - # we don't want application being called when being used as a library, but we need it to run if called directly or from symlinks etc - #-- choose a policy and leave the others commented. - #set is_called_directly $is_namematch - #set is_called_directly $is_inodematch - - #puts "NATSORT: called_directly_namematch - $is_namematch" - #puts "NATSORT: called_directly_inodematch - $is_inodematch" - #flush stdout - - set is_called_directly [expr {$is_namematch || $is_inodematch}] - #set is_called_directly [expr {$is_namematch && $is_inodematch}] - ### - - - #puts stdout "called_directly_name: [called_directly_namematch] called_directly_inode: [called_directly_inodematch]" - } else { - #safe interp - set is_called_directly 0 - } - - - - proc test_pass_fail_message {pass {additional ""}} { - variable test_fail_msg - variable test_pass_msg - if {$pass} { - puts stderr $test_pass_msg - } else { - puts stderr $test_fail_msg - } - puts stderr $additional - } - - variable test_fail_msg "XXXXXXXXXXXX FAIL XXXXXXXXXXXXX" - variable test_pass_msg "------------ PASS -------------" - proc test_sort_1 {args} { - package require struct::list - puts stderr "---$args" - set args [check_flags -caller natsort:test_sort_1 -defaults [list -collate nocase -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] -values $args] - - puts stderr "test_sort_1 got args: $args" - - set unsorted_input { - 2.2.2 - 2.2.2.2 - 1a.1.1 - 1a.2.1.1 - 1.12.1 - 1.2.1.1 - 1.02.1.1 - 1.002b.1.1 - 1.1.1.2 - 1.1.1.1 - } - set input { -1.1.1 -1.1.1.2 -1.002b.1.1 -1.02.1.1 -1.2.1.1 -1.12.1 -1a.1.1 -1a.2.1.1 -2.2.2 -2.2.2.2 - } - - set sorted [natsort::sort $input {*}$args] - set is_match [struct::list equal $input $sorted] - - set msg "windows-explorer order" - - test_pass_fail_message $is_match $msg - puts stdout [string repeat - 40] - puts stdout INPUT - puts stdout [string repeat - 40] - foreach item $input { - puts stdout $item - } - puts stdout [string repeat - 40] - puts stdout OUTPUT - puts stdout [string repeat - 40] - foreach item $sorted { - puts stdout $item - } - test_pass_fail_message $is_match $msg - return [expr {!$is_match}] - } - proc test_sort_showsplits {args} { - package require struct::list - - set args [check_flags -caller natsort:test_sort_1 \ - -defaults [list -collate nocase -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 1 ] \ - -extras {all} \ - -values $args] - - set input1 { - a-b.txt - a.b.c.txt - b.c-txt - } - - - set input2 { - a.b.c.txt - a-b.txt - b.c-text - } - - foreach {msg testlist } [list "custom-order" $input1 "windows-explorer (should work with -winlike 1)" $input2] { - set sorted [natsort::sort $testlist {*}$args] - set is_match [struct::list equal $testlist $sorted] - - test_pass_fail_message $is_match $msg - puts stderr "INPUT" - puts stderr "[string repeat - 40]" - foreach item $testlist { - puts stdout $item - } - puts stderr "[string repeat - 40]" - puts stderr "OUTPUT" - puts stderr "[string repeat - 40]" - foreach item $sorted { - puts stdout $item - } - - test_pass_fail_message $is_match $msg - } - - #return [expr {!$is_match}] - - } - - #tcl proc dispatch order - non flag items up front - #trailing flags are paired even if supplied as solo flags e.g -l becomes -l 1 - proc commandline_ls {args} { - set operands [list] - set posn 0 - foreach a $args { - if {![string match -* $a]} { - lappend operands $a - } else { - set flag1_posn $posn - break - } - incr posn - } - set args [lrange $args $flag1_posn end] - - - set debug 0 - set posn [lsearch $args -debug] - if {$posn > 0} { - if {[lindex $args $posn+1]} { - set debug [lindex $args $posn+1] - } - } - if {$debug} { - puts stderr "|debug>commandline_ls got $args" - } - - #if first operand not supplied - replace it with current working dir - if {[lindex $operands 0] eq "\uFFFF"} { - lset operands 0 [pwd] - } - - set targets [list] - foreach op $operands { - if {$op ne "\uFFFF"} { - set opchars [split [file tail $op] ""] - if {"?" in $opchars || "*" in $opchars} { - lappend targets $op - } else { - #actual file or dir - set targetitem $op - set targetitem [file normalize $op] - if {![file exists $targetitem]} { - if {$debug} { - puts stderr "|debug>commandline_ls Unable to access path '$targetitem'" - } - } - lappend targets $targetitem - if {$debug} { - puts stderr "|debug>commandline_ls listing for $targetitem" - } - } - } - } - set args [check_flags -caller commandline_ls \ - -return flagged|defaults \ - -debugargs 0 \ - -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 -algorithm sort] \ - -required {all} \ - -extras {all} \ - -soloflags {-v -l} \ - -commandprocessors {} \ - -values $args ] - if {$debug} { - puts stderr "|debug>args: $args" - } - - - set algorithm [dict get $args -algorithm] - dict unset args -algorithm - - set allfolders [list] - set allfiles [list] - foreach item $targets { - if {[file exists $item]} { - if {[file type $item] eq "directory"} { - set dotfolders [glob -nocomplain -directory $item -type {d} -tail .*] - set folders [glob -nocomplain -directory $item -type {d} -tail *] - set allfolders [concat $allfolders $dotfolders $folders] - - set dotfiles [glob -nocomplain -directory $item -type {f} -tail .*] - set files [glob -nocomplain -directory $item -type {f} -tail *] - set allfiles [concat $allfiles $dotfiles $files] - } else { - #file (or link?) - set files [glob -nocomplain -directory [file dirname $item] -tail [file tail $item]] - set allfiles [concat $allfiles $files] - } - } else { - set folders [glob -nocomplain -directory $item -type {d} -tail [file tail $item]] - set allfolders [concat $allfolders $folders] - set files [glob -nocomplain -directory [file dirname $item] -tail [file tail $item]] - set allfiles [concat $allfiles $files] - } - } - - - set sorted_folders [natsort::sort $allfolders {*}$args] - set sorted_files [natsort::sort $allfiles {*}$args] - - foreach fold $sorted_folders { - puts stdout $fold - } - foreach file $sorted_files { - puts stdout $file - } - - return "-- ok printed to stdout [llength $sorted_folders] folders and [llength $sorted_files] files --" - } - - package require argp - argp::registerArgs commandline_test { - { -showsplits boolean 0} - { -stacktrace boolean 0} - { -debug boolean 0} - { -winlike boolean 0} - { -db string ":memory:"} - { -collate string "nocase"} - { -algorithm string "sort"} - { -topchars string "\uFFFF"} - { -testlist string {10 1 30 3}} - } - argp::setArgsNeeded commandline_test {-stacktrace} - proc commandline_test {test args} { - variable testlist - puts stdout "commandline_test got $args" - argp::parseArgs opts - puts stdout "commandline_test got [array get opts]" - set args [check_flags -caller natsort_commandline \ - -return flagged|defaults \ - -defaults [list -db :memory: -collate nocase -testlist $testlist -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ - -values $args] - - if {[string tolower $test] in [list "1" "true"]} { - set test "sort" - } else { - if {![llength [info commands $test]]} { - error "test $test not found" - } - } - dict unset args -test - set stacktrace [dict get $args -stacktrace] - # dict unset args -stacktrace - - set argtestlist [dict get $args -testlist] - dict unset args -testlist - - - set debug [dict get $args -debug] - - set collate [dict get $args -collate] - set db [dict get $args -db] - set winlike [dict get $args -winlike] - set topchars [dict get $args -topchars] - - - puts stderr "|test>-----start natsort::$test--- input list size : [llength $argtestlist]" - #set resultlist [$test $argtestlist -db $db -collate $collate -topchars $topchars -winlike $winlike] - set resultlist [$test $argtestlist {*}$args] - foreach nm $resultlist { - puts stdout $nm - } - puts stdout "|test>-----end natsort::$test--- sorted list size: [llength $resultlist]" - return "test end" - } - proc commandline_runtests {runtests args} { - set argvals [check_flags -caller commandline_runtests \ - -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits "\uFFFF" -runtests 1] \ - -values $args] - - puts stderr "runtests args: $argvals" - - #set runtests [dict get $argvals -runtests] - dict unset argvals -runtests - dict unset argvals -algorithm - - puts stderr "runtests args: $argvals" - #exit 0 - - set test_prefix "::natsort::test_sort_" - - if {$runtests eq "1"} { - set runtests "*" - } - - - set testcommands [info commands ${test_prefix}${runtests}] - if {![llength $testcommands]} { - puts stderr "No test commands matched -runtests argument '$runtests'" - puts stderr "Use 1 to run all tests" - set alltests [info commands ${test_prefix}*] - puts stderr "Valid tests are:" - - set prefixlen [string length $test_prefix] - foreach t $alltests { - set shortname [string range $t $prefixlen end] - puts stderr "$t = -runtests $shortname" - } - - } else { - foreach cmd $testcommands { - puts stderr [string repeat - 40] - puts stderr "calling $cmd with args: '$argvals'" - puts stderr [string repeat - 40] - $cmd {*}$argvals - } - } - exit 0 - } - proc help {args} { - puts stdout "natsort::help got '$args'" - return "Help not implemented" - } - proc natsort_pipe {args} { - #PIPELINE to take input list on stdin and write sorted list to stdout - #strip - from arglist - #set args [check_flags -caller natsort_pipeline \ - # -return all \ - # -defaults [list -db :memory: -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ - # -values $args] - - - set debug [dict get $args -debug] - if {$debug} { - puts stderr "|debug> natsort_pipe got args:'$args'" - } - set algorithm [dict get $args -algorithm] - dict unset args -algorithm - - set proclist [info commands ::natsort::sort*] - set algos [list] - foreach p $proclist { - lappend algos [namespace tail $p] - } - if {$algorithm ni [list {*}$proclist {*}$algos]} { - do_error "valid sort mechanisms: $algos" 2 - } - - - set input_list [list] - while {![eof stdin]} { - if {[gets stdin line] > 0} { - lappend input_list $line - } else { - if {[eof stdin]} { - - } else { - after 10 - } - } - } - - if {$debug} { - puts stderr "|debug> received [llength $input_list] list elements" - } - - set resultlist [$algorithm $input_list {*}$args] - if {$debug} { - puts stderr "|debug> returning [llength $resultlist] list elements" - } - foreach r $resultlist { - puts stdout $r - } - #exit 0 - - } - if {($is_called_directly)} { - set cmdprocessors { - {helpfinal {match "^help$" dispatch natsort::help}} - {helpfinal {sub -topic default "NONE"}} - } - #set args [check_flags \ - # -caller test1 \ - # -debugargs 2 \ - # -return arglist \ - # -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] \ - # -required {none} \ - # -extras {all} \ - # -commandprocessors $cmdprocessors \ - # -values $::argv ] - interp alias {} do_filter {} ::flagfilter::check_flags - - #mashopts are generally single-letter opts that can be run together e.g -l -d as -ld - set cmdprocessors { - {helpcmd {match "^help$" dispatch natsort::help singleopts {-v}}} - {helpcmd {sub -operand default \uFFFF singleopts {-l}}} - {lscmd {match "^ls$" dispatch natsort::commandline_ls dispatchtype tcl dispatchglobal 1 mashopts {-l -a} singleopts {-l -a} pairopts {} longopts {--color=always}}} - {lscmd {sub dir default "\uFFFF"}} - {lscmd {sub dir2 default "\uFFFF"}} - {lscmd {sub dir3 default "\uFFFF"}} - {lscmd {sub dir4 default "\uFFFF"}} - {lscmd {sub dir5 default "\uFFFF"}} - {lscmd {sub dir6 default "\uFFFF"}} - {runtests {match "^-tests$" dispatch natsort::commandline_runtests singleopts {-l}}} - {runtests {sub testname default "1" singleopts {-l}}} - {pipecmd {match "^-$" dispatch natsort::natsort_pipe dispatchtype tcl}} - } - set arglist [do_filter \ - -debugargs 0 \ - -debugargsonerror 2 \ - -caller cline_dispatch1 \ - -return all \ - -soloflags {-v -x} \ - -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] \ - -required {all} \ - -extras {all} \ - -commandprocessors $cmdprocessors \ - -values $::argv ] - - - #mashopts are generally single-letter opts that can be run together e.g -l -d as -ld - set cmdprocessors { - {testcmd {match "^test$" dispatch natsort::commandline_test singleopts {-l}}} - {testcmd {sub testname default "1" singleopts {-l}}} - } - set arglist [check_flags \ - -debugargs 0 \ - -caller cline_dispatch2 \ - -return all \ - -soloflags {-v -l} \ - -defaults [list -collate nocase -algorithm sort -testlist "1 2 3 10" -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0 ] \ - -required {all} \ - -extras {all} \ - -commandprocessors $cmdprocessors \ - -values $::argv ] - - - - - #set cmdprocessors [list] - #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors $cmdprocessors -values $::argv ] - - #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {-cmd {-cmd -cmdarg1 -default "."} {-cmd -cmdarg2 -default j}} -values $::argv ] - #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {{-cmd -default help} {-cmd -cmdarg1 -default "."} {-cmd -cmdarg2 -default j}} -values $::argv ] - #set args [check_flags -caller test1 -defaults [list -collate nocase -algorithm sort -topchars "\uFFFF" -winlike 0 -debug 0 -stacktrace 0 -showsplits 0] -required {all} -extras {none} -commandprocessors {ls {ls lsdir -default "\uFFFF"}} -values $::argv ] - - puts stderr "natsort directcall exit" - flush stderr - exit 0 - - if {$::argc} { - - } - } -} - - -package provide natsort [namespace eval natsort { - variable version - set version 0.1.1.6 -}] - - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/oolib-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/oolib-0.1.2.tm deleted file mode 100644 index 858c61cd..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/oolib-0.1.2.tm +++ /dev/null @@ -1,201 +0,0 @@ -#JMN - api should be kept in sync with package patternlib where possible -# -package provide oolib [namespace eval oolib { - variable version - set version 0.1.2 -}] - -namespace eval oolib { - oo::class create collection { - variable o_data ;#dict - #variable o_alias - constructor {} { - set o_data [dict create] - } - method info {} { - return [dict info $o_data] - } - method count {} { - return [dict size $o_data] - } - method isEmpty {} { - expr {[dict size $o_data] == 0} - } - method names {{globOrIdx {}}} { - if {[llength $globOrIdx]} { - if {[string is integer -strict $globOrIdx]} { - set idx $globOrIdx - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $idx} result]} { - error "[self object] no such index : '$idx'" - } else { - return $result - } - } else { - #glob - return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] - } - } else { - return [dict keys $o_data] - } - } - #like names but without globbing - method keys {} { - dict keys $o_data - } - method key {{posn 0}} { - if {$posn < 0} { - set posn "end-[expr {abs($posn + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $posn} result]} { - error "[self object] no such index : '$posn'" - } else { - return $result - } - } - method hasKey {key} { - dict exists $o_data $key - } - method get {} { - return $o_data - } - method items {} { - return [dict values $o_data] - } - method item {key} { - if {[string is integer -strict $key]} { - if {$key >= 0} { - set valposn [expr {(2*$key) +1}] - return [lindex $o_data $valposn] - } else { - set key "end-[expr {abs($key + 1)}]" - return [lindex $o_data $key] - #return [lindex [dict keys $o_data] $key] - } - } - if {[dict exists $o_data $key]} { - return [dict get $o_data $key] - } - } - #inverse lookup - method itemKeys {value} { - set value_indices [lsearch -all [dict values $o_data] $value] - set keylist [list] - foreach i $value_indices { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - method search {value args} { - set matches [lsearch {*}$args [dict values $o_data] $value] - if {"-inline" in $args} { - return $matches - } else { - set keylist [list] - foreach i $matches { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - } - #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? - #review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? - #method alias {newAlias existingKeyOrAlias} { - # if {[string is integer -strict $newAlias]} { - # error "[self object] collection key alias cannot be integer" - # } - # if {[string length $existingKeyOrAlias]} { - # set o_alias($newAlias) $existingKeyOrAlias - # } else { - # unset o_alias($newAlias) - # } - #} - #method aliases {{key ""}} { - # if {[string length $key]} { - # set result [list] - # foreach {n v} [array get o_alias] { - # if {$v eq $key} { - # lappend result $n $v - # } - # } - # return $result - # } else { - # return [array get o_alias] - # } - #} - ##if the supplied index is an alias, return the underlying key; else return the index supplied. - #method realKey {idx} { - # if {[catch {set o_alias($idx)} key]} { - # return $idx - # } else { - # return $key - # } - #} - method add {value key} { - if {[string is integer -strict $key]} { - error "[self object] collection key must not be an integer. Use another structure if integer keys required" - } - if {[dict exists $o_data $key]} { - error "[self object] col_processors object error: key '$key' already exists in collection" - } - dict set o_data $key $value - return [expr {[dict size $o_data] - 1}] ;#return index of item - } - method remove {idx {endRange ""}} { - if {[string length $endRange]} { - error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" - } - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx+1)}]" - } - set key [lindex [dict keys $o_data] $idx] - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - if {$posn < 0} { - error "[self object] no such index: '$idx' in this collection" - } - } - dict unset o_data $key - return - } - method clear {} { - set o_data [dict create] - return - } - method reverse_the_collection {} { - #named slightly obtusely because reversing the data when there may be references held is a potential source of bugs - #the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. - #todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. - set dictnew [dict create] - foreach k [lreverse [dict keys $o_data]] { - dict set dictnew $k [dict get $o_data $k] - } - set o_data $dictnew - return - } - #review - cmd as list vs cmd as script? - method map {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list {*}$cmd $v]] - } - return $seed - } - method objectmap {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list $v {*}$cmd]] - } - return $seed - } - } - -} - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.6.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.6.tm deleted file mode 100644 index b4e59ec6..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.6.tm +++ /dev/null @@ -1,4774 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) Julian Noble 2003-2023 -# -# @@ Meta Begin -# Application overtype 1.6.6 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin overtype_module_overtype 0 1.6.6] -#[copyright "2024"] -#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] -#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] -#[require overtype] -#[keywords module text ansi] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of overtype -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by overtype -#[list_begin itemized] - -package require Tcl 8.6- -package require textutil -package require punk::lib ;#required for lines_as_list -package require punk::ansi ;#required to detect, split, strip and calculate lengths -package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars -package require punk::assertion -#*** !doctools -#[item] [package {Tcl 8.6}] -#[item] [package textutil] -#[item] [package punk::ansi] -#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes -#[item] [package punk::char] -#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -#PERFORMANCE notes -#overtype is very performance sensitive - used in ansi output all over the place ie needs to be optimised -#NOTE use of tcl::dict::for tcl::string::range etc instead of ensemble versions. This is for the many tcl 8.6/8.7 interps which don't compile ensemble commands when in safe interps -#similar for tcl::namespace::eval - but this is at least on some versions of Tcl - faster even in a normal interp. Review to see if that holds for Tcl 9. -#for string map: when there are exactly 2 elements - it is faster to use a literal which has a special case optimisation in the c code -#ie use tcl::string::map {\n ""} ... instead of tcl::string::map [list \n ""] ... -#note that we can use unicode (e.g \uFF31) and other escapes such as \t within these curly braces - we don't have to use double quotes -#generally using 'list' is preferred for the map as less error prone. -#can also use: tcl::string::map "token $var" .. but be careful regarding quoting and whitespace in var. This should be used sparingly if at all. - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section API] - - -#Julian Noble - 2003 -#Released under standard 'BSD license' conditions. -# -#todo - ellipsis truncation indicator for center,right - -#v1.4 2023-07 - naive ansi color handling - todo - fix tcl::string::range -# - need to extract and replace ansi codes? - -tcl::namespace::eval overtype { - namespace import ::punk::assertion::assert - punk::assertion::active true - - namespace path ::punk::lib - - namespace export * - variable default_ellipsis_horizontal "..." ;#fallback - variable default_ellipsis_vertical "..." - tcl::namespace::eval priv { - proc _init {} { - upvar ::overtype::default_ellipsis_horizontal e_h - upvar ::overtype::default_ellipsis_vertical e_v - set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis - set e_v [format %c 0x22EE] - #The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text - #Also - unicode ellipsis has semantic meaning that other processors can interpret - #unicode does also provide a midline horizontal ellipsis 0x22EF - - #set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal - #if {![catch {package require punk::char}]} { - # set e [punk::char::charshort boxd_ltdshhz] - #} - } - } - priv::_init -} -proc overtype::about {} { - return "Simple text formatting. Author JMN. BSD-License" -} - -tcl::namespace::eval overtype { - variable grapheme_widths [tcl::dict::create] - - variable escape_terminals - #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). - tcl::dict::set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] - #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - tcl::dict::set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals - - #self-contained 2 byte ansi escape sequences - review more? - variable ansi_2byte_codes_dict - set ansi_2byte_codes_dict [tcl::dict::create\ - "reset_terminal" "\u001bc"\ - "save_cursor_posn" "\u001b7"\ - "restore_cursor_posn" "\u001b8"\ - "cursor_up_one" "\u001bM"\ - "NEL - Next Line" "\u001bE"\ - "IND - Down one line" "\u001bD"\ - "HTS - Set Tab Stop" "\u001bH"\ - ] - - #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. - # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ -} - - - - -proc overtype::string_columns {text} { - if {[punk::ansi::ta::detect $text]} { - #error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::ansistrip. Alternatively try punk::ansi::printing_length" - set text [punk::ansi::ansistrip $text] - } - return [punk::char::ansifreestring_width $text] -} - -#todo - consider a way to merge overtype::left/centre/right -#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock -#overtype::renderblock could render the input to a defined (possibly overflowing in x or y) rectangle overlapping the underlay. -#(i.e not even necessariy having it's top left within the underlay) -tcl::namespace::eval overtype::priv { -} - -#could return larger than renderwidth -proc _get_row_append_column {row} { - #obsolete? - upvar outputlines outputlines - set idx [expr {$row -1}] - if {$row <= 1 || $row > [llength $outputlines]} { - return 1 - } else { - upvar opt_expand_right expand_right - upvar renderwidth renderwidth - set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] - set endpos [expr {$existinglen +1}] - if {$expand_right} { - return $endpos - } else { - if {$endpos > $renderwidth} { - return $renderwidth + 1 - } else { - return $endpos - } - } - } -} - -tcl::namespace::eval overtype { - #*** !doctools - #[subsection {Namespace overtype}] - #[para] Core API functions for overtype - #[list_begin definitions] - - - - #tcl::string::range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r - #render onto an already-rendered (ansi already processed) 'underlay' string, a possibly ansi-laden 'overlay' string. - #The underlay and overlay can be multiline blocks of text of varying line lengths. - #The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text. - #This is a single-shot rendering of strings - ie there is no way to chain another call containing a cursor-restore to previously rendered output and have it know about any cursor-saves in the first call. - # a cursor start position other than top-left is a possible addition to consider. - #see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline - proc renderspace {args} { - #*** !doctools - #[call [fun overtype::renderspace] [arg args] ] - #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext - - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext - variable default_ellipsis_horizontal - - if {[llength $args] < 2} { - error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - set optargs [lrange $args 0 end-2] - if {[llength $optargs] % 2 == 0} { - set overblock [lindex $args end] - set underblock [lindex $args end-1] - #lassign [lrange $args end-1 end] underblock overblock - set argsflags [lrange $args 0 end-2] - } else { - set optargs [lrange $args 0 end-1] - if {[llength $optargs] %2 == 0} { - set overblock [lindex $args end] - set underblock "" - set argsflags [lrange $args 0 end-1] - } else { - error "renderspace expects opt-val pairs followed by: or just " - } - } - set opts [tcl::dict::create\ - -bias ignored\ - -width \uFFEF\ - -height \uFFEF\ - -startcolumn 1\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -expand_right 0\ - -appendlines 1\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -experimental 0\ - -cp437 0\ - -looplimit \uFFEF\ - -crm_mode 0\ - -reverse_mode 0\ - -insert_mode 0\ - -wrap 0\ - -info 0\ - -console {stdin stdout stderr}\ - ] - #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. - # it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling) - # - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences. - # - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW. - # - further implication is that if expand_right grows the virtual renderspace terminal width - - # then some sort of reflow/rerender needs to be done for preceeding lines? - # possibly not - as expand_right is distinct from a normal terminal-width change event, - # expand_right being primarily to support other operations such as textblock::table - - #todo - viewport width/height as separate concept to terminal width/height? - #-ellipsis args not used if -wrap is true - foreach {k v} $argsflags { - switch -- $k { - -looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - - -transparent - -exposed1 - -exposed2 - -experimental - - -expand_right - -appendlines - - -reverse_mode - -crm_mode - -insert_mode - - -cp437 - - -info - -console { - tcl::dict::set opts $k $v - } - -wrap - -autowrap_mode { - #temp alias -autowrap_mode for consistency with renderline - #todo - - tcl::dict::set opts -wrap $v - } - default { - error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - #review - expand_left for RTL text? - set opt_expand_right [tcl::dict::get $opts -expand_right] - #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. - set opt_width [tcl::dict::get $opts -width] - set opt_height [tcl::dict::get $opts -height] - set opt_startcolumn [tcl::dict::get $opts -startcolumn] - set opt_appendlines [tcl::dict::get $opts -appendlines] - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_exposed1 [tcl::dict::get $opts -exposed1] ;#widechar_exposed_left - todo - set opt_exposed2 [tcl::dict::get $opts -exposed2] ;#widechar_exposed_right - todo - # -- --- --- --- --- --- - set opt_crm_mode [tcl::dict::get $opts -crm_mode] - set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] - set opt_insert_mode [tcl::dict::get $opts -insert_mode] - ##### - # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. - set opt_autowrap_mode [tcl::dict::get $opts -wrap] - #??? wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) - ##### - # -- --- --- --- --- --- - set opt_cp437 [tcl::dict::get $opts -cp437] - set opt_info [tcl::dict::get $opts -info] - - - - # ---------------------------- - # -experimental dev flag to set flags etc - # ---------------------------- - set data_mode 0 - set edit_mode 0 - set opt_experimental [tcl::dict::get $opts -experimental] - foreach o $opt_experimental { - switch -- $o { - data_mode { - set data_mode 1 - } - edit_mode { - set edit_mode 1 - } - } - } - # ---------------------------- - - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - - #set underlines [split $underblock \n] - - #underblock is a 'rendered' block - so width height make sense - #only non-cursor affecting and non-width occupying ANSI codes should be present. - #ie SGR codes and perhaps things such as PM - although generally those should have been pushed to the application already - #renderwidth & renderheight were originally used with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. - - if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} { - lassign [blocksize $underblock] _w renderwidth _h renderheight - if {$opt_width ne "\uFFEF"} { - set renderwidth $opt_width - } - if {$opt_height ne "\uFFEF"} { - set renderheight $opt_height - } - } else { - set renderwidth $opt_width - set renderheight $opt_height - } - #initial state for renderspace 'terminal' reset - set initial_state [dict create\ - renderwidth $renderwidth\ - renderheight $renderheight\ - crm_mode $opt_crm_mode\ - reverse_mode $opt_reverse_mode\ - insert_mode $opt_insert_mode\ - autowrap_mode $opt_autowrap_mode\ - cp437 $opt_cp437\ - ] - #modes - #e.g insert_mode can be toggled by insert key or ansi IRM sequence CSI 4 h|l - #opt_startcolumn ?? - DECSLRM ? - set vtstate $initial_state - - # -- --- --- --- - #REVIEW - do we need ansi resets in the underblock? - if {$underblock eq ""} { - set underlines [lrepeat $renderheight ""] - } else { - set underblock [textblock::join_basic -- $underblock] ;#ensure properly rendered - ansi per-line resets & replays - set underlines [split $underblock \n] - } - #if {$underblock eq ""} { - # set blank "\x1b\[0m\x1b\[0m" - # #set underlines [list "\x1b\[0m\x1b\[0m"] - # set underlines [lrepeat $renderheight $blank] - #} else { - # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW - # set underlines [lines_as_list -ansiresets 1 $underblock] - #} - # -- --- --- --- - - #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. - #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output renderwidth - #In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time. - #(in cases where there are interline moves or cursor jumps anyway) - #This works - but doesn't seem efficient. - #On the other hand.. maybe it depends on the data. For simpler files it's more efficient than splitting first - - #a hack until we work out how to avoid infinite loops... - # - set looplimit [tcl::dict::get $opts -looplimit] - if {$looplimit eq "\uFFEF"} { - #looping for each char is worst case (all newlines?) - anything over that is an indication of something broken? - #do we need any margin above the length? (telnet mapscii.me test) - set looplimit [expr {[tcl::string::length $overblock] + 10}] - } - - #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height - #lassign [blocksize $overblock] _w overblock_width _h overblock_height - - set scheme 4 - switch -- $scheme { - 0 { - #one big chunk - set inputchunks [list $overblock] - } - 1 { - set inputchunks [punk::ansi::ta::split_codes $overblock] - } - 2 { - - #split into lines if possible first - then into plaintext/ansi-sequence chunks ? - set inputchunks [list ""] ;#put an empty plaintext split in for starters - set i 1 - set lines [split $overblock \n] - foreach ln $lines { - if {$i < [llength $lines]} { - append ln \n - } - set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single? - set lastpt [lindex $inputchunks end] - lset inputchunks end [tcl::string::cat $lastpt [lindex $sequence_split 0]] - lappend inputchunks {*}[lrange $sequence_split 1 end] - incr i - } - } - 3 { - #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice - set lflines [list] - set inputchunks [split $overblock \n] - foreach ln $inputchunks { - append ln \n - lappend lflines $ln - } - if {[llength $lflines]} { - lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] - } - #set inputchunks $lflines[unset lflines] - set inputchunks [lindex [list $lflines [unset lflines]] 0] - - } - 4 { - set inputchunks [list] - foreach ln [split $overblock \n] { - lappend inputchunks $ln\n - } - if {[llength $inputchunks]} { - lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] - } - } - } - - - - - set replay_codes_underlay [tcl::dict::create 1 ""] - #lappend replay_codes_overlay "" - set replay_codes_overlay "[punk::ansi::a]" - set unapplied "" - set cursor_saved_position [tcl::dict::create] - set cursor_saved_attributes "" - - - set outputlines $underlines - set overidx 0 - - #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext - set row 1 - #if {$data_mode} { - # set col [_get_row_append_column $row] - #} else { - set col $opt_startcolumn - #} - - set instruction_stats [tcl::dict::create] - - set loop 0 - #while {$overidx < [llength $inputchunks]} { } - - while {[llength $inputchunks]} { - #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" - set overtext [lpop inputchunks 0] - if {![tcl::string::length $overtext]} { - incr loop - continue - } - #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" - set undertext [lindex $outputlines [expr {$row -1}]] - set renderedrow $row - - #renderline pads each underaly line to width with spaces and should track where end of data is - - - #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext $replay_codes_overlay$overtext - if {[tcl::dict::exists $replay_codes_underlay $row]} { - set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext - } - #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l - set renderopts [list -experimental $opt_experimental\ - -cp437 $opt_cp437\ - -info 1\ - -crm_mode [tcl::dict::get $vtstate crm_mode]\ - -insert_mode [tcl::dict::get $vtstate insert_mode]\ - -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ - -reverse_mode [tcl::dict::get $vtstate reverse_mode]\ - -cursor_restore_attributes $cursor_saved_attributes\ - -transparent $opt_transparent\ - -width [tcl::dict::get $vtstate renderwidth]\ - -exposed1 $opt_exposed1\ - -exposed2 $opt_exposed2\ - -expand_right $opt_expand_right\ - -cursor_column $col\ - -cursor_row $row\ - ] - set rinfo [renderline {*}$renderopts $undertext $overtext] - - set instruction [tcl::dict::get $rinfo instruction] - tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode] - tcl::dict::set vtstate insert_mode [tcl::dict::get $rinfo insert_mode] - tcl::dict::set vtstate autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;# - tcl::dict::set vtstate reverse_mode [tcl::dict::get $rinfo reverse_mode] - #how to support reverse_mode in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? - # - review - the answer is probably that we don't need to - it is set/reset only during application of overtext - - #Note carefully the difference betw overflow_right and unapplied. - #overflow_right may need to be included in next run before the unapplied data - #overflow_right most commonly has data when in insert_mode - set rendered [tcl::dict::get $rinfo result] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set overflow_right_column [tcl::dict::get $rinfo overflow_right_column] - set unapplied [tcl::dict::get $rinfo unapplied] - set unapplied_list [tcl::dict::get $rinfo unapplied_list] - set post_render_col [tcl::dict::get $rinfo cursor_column] - set post_render_row [tcl::dict::get $rinfo cursor_row] - set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position] - set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes] - set visualwidth [tcl::dict::get $rinfo visualwidth] ;#column width of what is 'rendered' for the line - set insert_lines_above [tcl::dict::get $rinfo insert_lines_above] - set insert_lines_below [tcl::dict::get $rinfo insert_lines_below] - tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay] - - #lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - if {0 && [tcl::dict::get $vtstate reverse_mode]} { - #test branch - todo - prune - puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" - #review - #JMN3 - set existing_reverse_state 0 - #split_codes_single is single esc sequence - but could have multiple sgr codes within one esc sequence - #e.g \x1b\[0;31;7m has a reset,colour red and reverse - set codeinfo [punk::ansi::codetype::sgr_merge [list $replay_codes_overlay] -info 1] - set codestate_reverse [dict get $codeinfo codestate reverse] - switch -- $codestate_reverse { - 7 { - set existing_reverse_state 1 - } - 27 { - set existing_reverse_state 0 - } - "" { - } - } - if {$existing_reverse_state == 0} { - set rflip [a+ reverse] - } else { - #reverse of reverse - set rflip [a+ noreverse] - } - #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) - set replay_codes_overlay [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] - puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" - } - - - - #-- todo - detect looping properly - if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { - puts stderr "overtype::renderspace loop?" - puts [ansistring VIEW $rinfo] - break - } - #-- - - if {[tcl::dict::size $c_saved_pos] >= 1} { - set cursor_saved_position $c_saved_pos - set cursor_saved_attributes $c_saved_attributes - } - - - set overflow_handled 0 - - - - set nextprefix "" - - - #todo - handle potential insertion mode as above for cursor restore? - #keeping separate branches for debugging - review and merge as appropriate when stable - set instruction_type [lindex $instruction 0] ;#some instructions have params - tcl::dict::incr instruction_stats $instruction_type - switch -- $instruction_type { - reset { - #reset the 'renderspace terminal' (not underlying terminal) - set row 1 - set col 1 - set vtstate [tcl::dict::merge $vtstate $initial_state] - #todo - clear screen - } - {} { - #end of supplied line input - #lf included in data - set row $post_render_row - set col $post_render_col - if {![llength $unapplied_list]} { - if {$overflow_right ne ""} { - incr row - } - } else { - puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" - } - set col $opt_startcolumn - } - up { - - #renderline knows it's own line number, and knows not to go above row l - #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. - #row returned should be correct. - #column may be the overflow column - as it likes to report that to the caller. - - #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. - #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review - #puts stderr "up $post_render_row" - #puts stderr "$rinfo" - - #puts stdout "1 row:$row col $col" - set row $post_render_row - #data_mode (naming?) determines if we move to end of existing data or not. - #data_mode 0 means ignore existing line length and go to exact column - #set by -experimental flag - if {$data_mode == 0} { - set col $post_render_col - } else { - #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data - #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - } - - #puts stdout "2 row:$row col $col" - #puts stdout "-----------------------" - #puts stdout $rinfo - #flush stdout - } - down { - if {$data_mode == 0} { - #renderline doesn't know how far down we can go.. - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } - set row $post_render_row - set col $post_render_col - } else { - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - - } - } - restore_cursor { - #testfile belinda.ans uses this - - #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" - if {[tcl::dict::exists $cursor_saved_position row]} { - set row [tcl::dict::get $cursor_saved_position row] - set col [tcl::dict::get $cursor_saved_position column] - #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" - #set nextprefix $cursor_saved_attributes - #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes - #set replay_codes_overlay $cursor_saved_attributes - set cursor_saved_position [tcl::dict::create] - set cursor_saved_attributes "" - } else { - #TODO - #?restore without save? - #should move to home position and reset ansi SGR? - #puts stderr "overtype::renderspace cursor_restore without save data available" - } - #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it - #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. - if {!$overflow_handled && $overflow_right ne ""} { - #wrap before restore? - possible effect on saved cursor position - #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc - #we can just insert another call to renderline to solve this.. ? - #It would perhaps be more properly handled as a queue of instructions from our initial renderline call - #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks - - puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" - - set sub_info [overtype::renderline\ - -info 1\ - -width [tcl::dict::get $vtstate renderwidth]\ - -insert_mode [tcl::dict::get $vtstate insert_mode]\ - -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ - -expand_right [tcl::dict::get $opts -expand_right]\ - ""\ - $overflow_right\ - ] - set foldline [tcl::dict::get $sub_info result] - tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? - tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. - linsert outputlines $renderedrow $foldline - #review - row & col set by restore - but not if there was no save.. - } - set overflow_handled 1 - - } - move { - ######## - if {$post_render_row > [llength $outputlines]} { - #Ansi moves need to create new lines ? - #if {$opt_appendlines} { - # set diff [expr {$post_render_row - [llength $outputlines]}] - # if {$diff > 0} { - # lappend outputlines {*}[lrepeat $diff ""] - # } - # set row $post_render_row - #} else { - set row [llength $outputlines] - #} - } else { - set row $post_render_row - } - ####### - set col $post_render_col - #overflow + unapplied? - } - clear_and_move { - #e.g 2J - if {$post_render_row > [llength $outputlines]} { - set row [llength $outputlines] - } else { - set row $post_render_row - } - set col $post_render_col - set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant - set clearedlines [list] - foreach ln $outputlines { - lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $renderwidth]\x1b\[0m - if 0 { - - set lineparts [punk::ansi::ta::split_codes $ln] - set numcells 0 - foreach {pt _code} $lineparts { - if {$pt ne ""} { - foreach grapheme [punk::char::grapheme_split $pt] { - switch -- $grapheme { - " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - incr numcells 1 - } - default { - if {$grapheme eq "\u0000"} { - incr numcells 1 - } else { - incr numcells [grapheme_width_cached $grapheme] - } - } - } - - } - } - } - #replays/resets each line - lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\x1b\[0m - } - } - set outputlines $clearedlines - #todo - determine background/default to be in effect - DECECM ? - puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]" - #lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0] - - } - lf_start { - #raw newlines - # ---------------------- - #test with fruit.ans - #test - treating as newline below... - #append rendered $overflow_right - #set overflow_right "" - set row $renderedrow - incr row - if {$row > [llength $outputlines]} { - lappend outputlines "" - } - set col $opt_startcolumn - # ---------------------- - } - lf_mid { - - set edit_mode 0 - if {$edit_mode} { - set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] - set overflow_right "" - set unapplied "" - set row $post_render_row - #set col $post_render_col - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - if 1 { - if {$overflow_right ne ""} { - if {$opt_expand_right} { - append rendered $overflow_right - set overflow_right "" - } else { - #review - we should really make renderline do the work...? - set overflow_width [punk::ansi::printing_length $overflow_right] - if {$visualwidth + $overflow_width <= $renderwidth} { - append rendered $overflow_right - set overflow_right "" - } else { - if {[tcl::dict::get $vtstate autowrap_mode]} { - set outputlines [linsert $outputlines $renderedrow $overflow_right] - set overflow_right "" - set row [expr {$renderedrow + 2}] - } else { - set overflow_right "" ;#abandon - } - - if {0 && $visualwidth < $renderwidth} { - puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth" - error "incomplete - abandon?" - set overflowparts [punk::ansi::ta::split_codes $overflow_right] - set remaining_overflow $overflowparts - set filled 0 - foreach {pt code} $overflowparts { - lpop remaining_overflow 0 - if {$pt ne ""} { - set graphemes [punk::char::grapheme_split $pt] - set add "" - set addlen $visualwidth - foreach g $graphemes { - set w [overtype::grapheme_width_cached $g] - if {$addlen + $w <= $renderwidth} { - append add $g - incr addlen $w - } else { - set filled 1 - break - } - } - append rendered $add - } - if {!$filled} { - lpop remaining_overflow 0 ;#pop code - } - } - set overflow_right [join $remaining_overflow ""] - } - } - } - } - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - #old version - known to work with various ansi graphics - e.g fruit.ans - # - but fails to limit lines to renderwidth when expand_right == 0 - append rendered $overflow_right - set overflow_right "" - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } - } - } - lf_overflow { - #linefeed after renderwidth e.g at column 81 for an 80 col width - #we may also have other control sequences that came after col 80 e.g cursor save - - if 0 { - set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] - set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] - set rhs "" - - #assertion - there should be no overflow.. - puts $lhs - } - if {![tcl::dict::get $vtstate insert_mode]} { - assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode - } - - set row $post_render_row - #set row $renderedrow - #incr row - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - set col $opt_startcolumn - - } - newlines_above { - #we get a newlines_above instruction when received at column 1 - #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) - #in other cases - we want to treat at column 1 the same as any other - - puts "--->newlines_above" - puts "rinfo: $rinfo" - #renderline doesn't advance the row for us - the caller has the choice to implement or not - set row $post_render_row - set col $post_render_col - if {$insert_lines_above > 0} { - set row $renderedrow - set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] - incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above - #? set row $post_render_row #can renderline tell us? - } - } - newlines_below { - #obsolete? - use for ANSI insert lines sequence - if {$data_mode == 0} { - puts --->nl_below - set row $post_render_row - set col $post_render_col - if {$insert_lines_below == 1} { - #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] - #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] - #set rhs "" - #if {$overflow_right ne ""} { - # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] - # set rhs [textblock::frame -title overflow_right $rhs] - #} - #puts [textblock::join $lhs $rhs] - - #rendered - append rendered $overflow_right - # - - - set overflow_right "" - set row $renderedrow - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat $insert_lines_below ""] - } - incr row $insert_lines_below - set col $opt_startcolumn - } - } else { - set row $post_render_row - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } else { - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - } - } - } - wrapmoveforward { - #doesn't seem to be used by fruit.ans testfile - #used by dzds.ans - #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO - set c $renderwidth - set r $post_render_row - if {$post_render_col > $renderwidth} { - set i $c - while {$i <= $post_render_col} { - if {$c == $renderwidth+1} { - incr r - if {$opt_appendlines} { - if {$r < [llength $outputlines]} { - lappend outputlines "" - } - } - set c $opt_startcolumn - } else { - incr c - } - incr i - } - set col $c - } else { - #why are we getting this instruction then? - puts stderr "wrapmoveforward - test" - set r [expr {$post_render_row +1}] - set c $post_render_col - } - set row $r - set col $c - } - wrapmovebackward { - set c $renderwidth - set r $post_render_row - if {$post_render_col < 1} { - set c 1 - set i $c - while {$i >= $post_render_col} { - if {$c == 0} { - if {$r > 1} { - incr r -1 - set c $renderwidth - } else { - #leave r at 1 set c 1 - #testfile besthpav.ans first line top left border alignment - set c 1 - break - } - } else { - incr c -1 - } - incr i -1 - } - set col $c - } else { - puts stderr "Wrapmovebackward - but postrendercol >= 1???" - } - set row $r - set col $c - } - overflow { - #normal single-width grapheme overflow - #puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" - set row $post_render_row ;#renderline will not advance row when reporting overflow char - if {[tcl::dict::get $vtstate autowrap_mode]} { - incr row - set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? - } else { - set col $post_render_col - #set unapplied "" ;#this seems wrong? - #set unapplied [tcl::string::range $unapplied 1 end] - #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs - #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate - #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' - set idx 0 - set next_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set next_grapheme_index $idx - break - } - incr idx - } - assert {$next_grapheme_index >= 0} - #drop the overflow grapheme - keeping all codes in place. - set unapplied [join [lreplace $unapplied_list $next_grapheme_index $next_grapheme_index] ""] - #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines - - set overflow_handled 1 - #handled by dropping overflow if any - } - } - overflow_splitchar { - set row $post_render_row ;#renderline will not advance row when reporting overflow char - - #2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts - #todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc - if {[tcl::dict::get $vtstate autowrap_mode]} { - if {$renderwidth < 2} { - #edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character - set idx 0 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx - } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] - } else { - set col $opt_startcolumn - incr row - } - } else { - set overflow_handled 1 - #handled by dropping entire overflow if any - if {$renderwidth < 2} { - set idx 0 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx - } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] - } - } - - } - vt { - - #can vt add a line like a linefeed can? - set row $post_render_row - set col $post_render_col - } - set_window_title { - set newtitle [lindex $instruction 1] - puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'" - # - } - reset_colour_palette { - puts stderr "overtype::renderspace instruction '$instruction' unimplemented" - } - default { - puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'" - } - - } - - - if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} { - #not allowed to overflow column or wrap therefore we get overflow data to truncate - if {[tcl::dict::get $opts -ellipsis]} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim [punk::ansi::ansistrip $lostdata]] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::right $rendered $opt_ellipsistext] - } - set overflow_handled 1 - } else { - #no wrap - no ellipsis - silently truncate - set overflow_handled 1 - } - } - - - - if {$renderedrow <= [llength $outputlines]} { - lset outputlines [expr {$renderedrow-1}] $rendered - } else { - if {$opt_appendlines} { - lappend outputlines $rendered - } else { - #? - lset outputlines [expr {$renderedrow-1}] $rendered - } - } - - if {!$overflow_handled} { - append nextprefix $overflow_right - } - - append nextprefix $unapplied - - if 0 { - if {$nextprefix ne ""} { - set nextoveridx [expr {$overidx+1}] - if {$nextoveridx >= [llength $inputchunks]} { - lappend inputchunks $nextprefix - } else { - #lset overlines $nextoveridx $nextprefix[lindex $overlines $nextoveridx] - set inputchunks [linsert $inputchunks $nextoveridx $nextprefix] - } - } - } - - if {$nextprefix ne ""} { - set inputchunks [linsert $inputchunks 0 $nextprefix] - } - - - incr overidx - incr loop - if {$loop >= $looplimit} { - puts stderr "overtype::renderspace looplimit reached ($looplimit)" - lappend outputlines "[a+ red bold] - looplimit $looplimit reached[a]" - set Y [a+ yellow bold] - set RST [a] - set sep_header ----DEBUG----- - set debugmsg "" - append debugmsg "${Y}${sep_header}${RST}" \n - append debugmsg "looplimit $looplimit reached\n" - append debugmsg "data_mode:$data_mode\n" - append debugmsg "opt_appendlines:$opt_appendlines\n" - append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n" - append debugmsg "prev_col :[tcl::dict::get $renderopts -cursor_column]\n" - tcl::dict::for {k v} $rinfo { - append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n - } - append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n - - puts stdout $debugmsg - #todo - config regarding error dumps rather than just dumping in working dir - set fd [open [pwd]/error_overtype.txt w] - puts $fd $debugmsg - close $fd - error $debugmsg - break - } - } - - set result [join $outputlines \n] - if {!$opt_info} { - return $result - } else { - #emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window? - #append result \n$instruction_stats\n - set inforesult [dict create\ - result $result\ - last_instruction $instruction\ - instruction_stats $instruction_stats\ - ] - if {$opt_info == 2} { - return [pdict -channel none inforesult] - } else { - return $inforesult - } - } - } - - #todo - left-right ellipsis ? - proc centre {args} { - variable default_ellipsis_horizontal - if {[llength $args] < 2} { - error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} - } - - foreach {underblock overblock} [lrange $args end-1 end] break - - #todo - vertical vs horizontal overflow for blocks - set opts [tcl::dict::create\ - -bias left\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - ] - set argsflags [lrange $args 0 end-2] - foreach {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - # -- --- --- --- --- --- - - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - #set renderwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w renderwidth _h renderheight - set overlines [split $overblock \n] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {$renderwidth - $overblock_width}] - if {$under_exposed_max > 0} { - #background block is wider - if {$under_exposed_max % 2 == 0} { - #even left/right exposure - set left_exposed [expr {$under_exposed_max / 2}] - } else { - set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division - if {[tcl::string::tolower [tcl::dict::get $opts -bias]] eq "left"} { - set left_exposed $beforehalf - } else { - #bias to the right - set left_exposed [expr {$beforehalf + 1}] - } - } - } else { - set left_exposed 0 - } - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $renderwidth} { - set udiff [expr {$renderwidth - $ulen}] - set undertext "$undertext[string repeat { } $udiff]" - } - set undertext $replay_codes_underlay$undertext - set overtext $replay_codes_overlay$overtext - - set overflowlength [expr {$overtext_datalen - $renderwidth}] - #review - right-to-left langs should elide on left! - extra option required - - if {$overflowlength > 0} { - #overlay line wider or equal - #review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end? - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - set rendered [tcl::dict::get $rinfo result] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set unapplied [tcl::dict::get $rinfo unapplied] - #todo - get replay_codes from overflow_right instead of wherever it was truncated? - - #overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified - if {![tcl::dict::get $opts -overflow]} { - #lappend outputlines [tcl::string::range $overtext 0 [expr {$renderwidth - 1}]] - #set overtext [tcl::string::range $overtext 0 $renderwidth-1 ] - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - #don't use tcl::string::range on ANSI data - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::right $rendered $opt_ellipsistext] - } - } - } - lappend outputlines $rendered - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent $undertext $overtext] - } else { - #background block is wider than or equal to data for this line - #lappend outputlines [renderline -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - set rinfo [renderline -info 1 -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - lappend outputlines [tcl::dict::get $rinfo result] - } - set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - } - return [join $outputlines \n] - } - - #overtype::right is for a rendered ragged underblock and a rendered ragged overblock - #ie we can determine the block width for bost by examining the lines and picking the longest. - # - proc right {args} { - #NOT the same as align-right - which should be done to the overblock first if required - variable default_ellipsis_horizontal - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? ?-transparent 0|? undertext overtext} - } - foreach {underblock overblock} [lrange $args end-1 end] break - - set opts [tcl::dict::create\ - -bias ignored\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -align "left"\ - ] - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_overflow [tcl::dict::get $opts -overflow] - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - set opt_align [tcl::dict::get $opts -align] - # -- --- --- --- --- --- - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - lassign [blocksize $underblock] _w renderwidth _h renderheight - set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] - set left_exposed $under_exposed_max - - - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $renderwidth} { - set udiff [expr {$renderwidth - $ulen}] - #puts xxx - append undertext [string repeat { } $udiff] - } - if {$overtext_datalen < $overblock_width} { - set odiff [expr {$overblock_width - $overtext_datalen}] - switch -- $opt_align { - left { - set startoffset 0 - } - right { - set startoffset $odiff - } - default { - set half [expr {$odiff / 2}] - #set lhs [string repeat { } $half] - #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left - #set rhs [string repeat { } $righthalf] - set startoffset $half - } - } - } else { - set startoffset 0 ;#negative? - } - - set undertext $replay_codes_underlay$undertext - set overtext $replay_codes_overlay$overtext - - set overflowlength [expr {$overtext_datalen - $renderwidth}] - if {$overflowlength > 0} { - #raw overtext wider than undertext column - set rinfo [renderline\ - -info 1\ - -insert_mode 0\ - -transparent $opt_transparent\ - -exposed1 $opt_exposed1 -exposed2 $opt_exposed2\ - -overflow $opt_overflow\ - -startcolumn [expr {1 + $startoffset}]\ - $undertext $overtext] - set replay_codes [tcl::dict::get $rinfo replay_codes] - set rendered [tcl::dict::get $rinfo result] - if {!$opt_overflow} { - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set ellipsis $replay_codes$opt_ellipsistext - #todo - overflow on left if allign = right?? - set rendered [overtype::right $rendered $ellipsis] - } - } - } - lappend outputlines $rendered - } else { - #padded overtext - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need overflow(exapnd_right) here - as although the overtext is short - it may oveflow due to the startoffset - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - lappend outputlines [tcl::dict::get $rinfo result] - } - set replay_codes [tcl::dict::get $rinfo replay_codes] - set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - } - - return [join $outputlines \n] - } - - proc left {args} { - overtype::block -blockalign left {*}$args - } - #overtype a (possibly ragged) underblock with a (possibly ragged) overblock - proc block {args} { - variable default_ellipsis_horizontal - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-blockalign left|centre|right? ?-textalign left|centre|right? ?-overflow [1|0]? ?-transparent 0|? undertext overtext} - } - #foreach {underblock overblock} [lrange $args end-1 end] break - lassign [lrange $args end-1 end] underblock overblock - - set opts [tcl::dict::create\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -textalign "left"\ - -textvertical "top"\ - -blockalign "left"\ - -blockalignbias left\ - -blockvertical "top"\ - ] - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical { - tcl::dict::set opts $k $v - } - default { - error "overtype::block unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_overflow [tcl::dict::get $opts -overflow] - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - set opt_textalign [tcl::dict::get $opts -textalign] - set opt_blockalign [tcl::dict::get $opts -blockalign] - if {$opt_blockalign eq "center"} { - set opt_blockalign "centre" - } - # -- --- --- --- --- --- - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - lassign [blocksize $underblock] _w renderwidth _h renderheight - set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] - - switch -- $opt_blockalign { - left { - set left_exposed 0 - } - right { - set left_exposed $under_exposed_max - } - centre { - if {$under_exposed_max > 0} { - #background block is wider - if {$under_exposed_max % 2 == 0} { - #even left/right exposure - set left_exposed [expr {$under_exposed_max / 2}] - } else { - set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division - if {[tcl::string::tolower [tcl::dict::get $opts -blockalignbias]] eq "left"} { - set left_exposed $beforehalf - } else { - #bias to the right - set left_exposed [expr {$beforehalf + 1}] - } - } - } else { - set left_exposed 0 - } - } - default { - set left_exposed 0 - } - } - - - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $renderwidth} { - set udiff [expr {$renderwidth - $ulen}] - #puts xxx - append undertext [string repeat { } $udiff] - } - if {$overtext_datalen < $overblock_width} { - set odiff [expr {$overblock_width - $overtext_datalen}] - switch -- $opt_textalign { - left { - set startoffset 0 - } - right { - set startoffset $odiff - } - default { - set half [expr {$odiff / 2}] - #set lhs [string repeat { } $half] - #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left - #set rhs [string repeat { } $righthalf] - set startoffset $half - } - } - } else { - set startoffset 0 ;#negative? - } - - set undertext $replay_codes_underlay$undertext - set overtext $replay_codes_overlay$overtext - - set overflowlength [expr {$overtext_datalen - $renderwidth}] - if {$overflowlength > 0} { - #raw overtext wider than undertext column - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -expand_right $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] - set replay_codes [tcl::dict::get $rinfo replay_codes] - set rendered [tcl::dict::get $rinfo result] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set unapplied [tcl::dict::get $rinfo unapplied] - if {!$opt_overflow} { - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - #don't use tcl::string::range on ANSI data - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::block -blockalign right $rendered $opt_ellipsistext] - } - } - - #if {$opt_ellipsis} { - # set show_ellipsis 1 - # if {!$opt_ellipsiswhitespace} { - # #we don't want ellipsis if only whitespace was lost - # set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - # if {[tcl::string::trim $lostdata] eq ""} { - # set show_ellipsis 0 - # } - # } - # if {$show_ellipsis} { - # set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] - # #todo - overflow on left if allign = right?? - # set rendered [overtype::right $rendered $ellipsis] - # } - #} - } - lappend outputlines $rendered - } else { - #padded overtext - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need expand_right here - as although the overtext is short - it may oveflow due to the startoffset - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - #puts stderr "--> [ansistring VIEW -lf 1 -nul 1 $rinfo] <--" - set overflow_right [tcl::dict::get $rinfo overflow_right] - set unapplied [tcl::dict::get $rinfo unapplied] - lappend outputlines [tcl::dict::get $rinfo result] - } - set replay_codes [tcl::dict::get $rinfo replay_codes] - set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - } - - return [join $outputlines \n] - } - - variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches - - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. - # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # - # - #-returnextra enables returning of overflow and length - #review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation? - #review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements - #(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char? - # This would probably be impractical to support for different fonts) - #todo - review transparency issues with single/double width characters - #bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer? - proc renderline {args} { - #*** !doctools - #[call [fun overtype::renderline] [arg args] ] - #[para] renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode commandline repl for the Tcl Punk Shell - #[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts - #[para] This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that can be joined & framed for layout display within a unix or windows terminal - #[para] Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't affect another. - #[para] Calling on the punk::ansi library - it can coalesce codes to keep the size down. - #[para] It is a giant mess of doing exactly what common wisdom says not to do... lots at once. - #[para] renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a static underlay - #[para] The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous to a terminal screen - but it can also be ragged in line length, or just blank. - #[para] The overlay couuld be similar - in which case it may often be used to overwrite a column or section of the underlay. - #[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place. - # - #[para] renderline itself only deals with a single line - or sometimes a single character. It is generally called from a loop that does further terminal-like or textblock processing. - #[para] By suppyling the -info 1 option - it can return various fields indicating the state of the render. - #[para] The main 3 are the result, overflow_right, and unapplied. - #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. - - #puts stderr "renderline '$args'" - variable optimise_ptruns - - if {[llength $args] < 2} { - error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} - } - set under [lindex $args end-1] - set over [lindex $args end] - #lassign [lrange $args end-1 end] under over - if {[string last \n $under] >= 0} { - error "overtype::renderline not allowed to contain newlines in undertext" - } - #if {[string first \n $over] >=0 || [string first \n $under] >= 0} { - # error "overtype::renderline not allowed to contain newlines" - #} - - #generally faster to create a new dict in the proc than to use a namespace variable to create dict once and link to variable (2024 8.6/8.7) - set opts [tcl::dict::create\ - -etabs 0\ - -width \uFFEF\ - -expand_right 0\ - -transparent 0\ - -startcolumn 1\ - -cursor_column 1\ - -cursor_row ""\ - -insert_mode 1\ - -crm_mode 0\ - -autowrap_mode 1\ - -reverse_mode 0\ - -info 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -cursor_restore_attributes ""\ - -cp437 0\ - -experimental {}\ - ] - #-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller - - #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return - #An empty string for cursor_row tells us we have no info about our own row context, and to return with an unapplied string if any row move occurs - - #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency, currsor movements to 2nd charcol, or overflow/expand_right - #todo - return info about such grapheme 'cuts' in -info structure and/or create option to raise an error - - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row - - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode - - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { - tcl::dict::set opts $k $v - } - default { - error "overtype::renderline unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_width [tcl::dict::get $opts -width] - set opt_etabs [tcl::dict::get $opts -etabs] - set opt_expand_right [tcl::dict::get $opts -expand_right] - set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay - set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay - set opt_row_context [tcl::dict::get $opts -cursor_row] - if {[string length $opt_row_context]} { - if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } { - error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - #The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode) - set opt_insert_mode [tcl::dict::get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) - #default is for overtype - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_autowrap_mode [tcl::dict::get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line - set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] ;#DECSNM - set opt_crm_mode [tcl::dict::get $opts -crm_mode];# CRM - show control character mode - # -- --- --- --- --- --- --- --- --- --- --- --- - set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes] - - set cp437_glyphs [tcl::dict::get $opts -cp437] - set cp437_map [tcl::dict::create] - if {$cp437_glyphs} { - set cp437_map [set ::punk::ansi::cp437_map] - #for cp437 images we need to map these *after* splitting ansi - #some old files might use newline for its glyph.. but we can't easily support that. - #Not sure how old files did it.. maybe cr lf in sequence was newline and any lone cr or lf were displayed as glyphs? - tcl::dict::unset cp437_map \n - } - - set opt_transparent [tcl::dict::get $opts -transparent] - if {$opt_transparent eq "0"} { - set do_transparency 0 - } else { - set do_transparency 1 - if {$opt_transparent eq "1"} { - set opt_transparent {[\s]} - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_returnextra [tcl::dict::get $opts -info] - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - # -- --- --- --- --- --- --- --- --- --- --- --- - - if {$opt_row_context eq ""} { - set cursor_row 1 - } else { - set cursor_row $opt_row_context - } - - set insert_mode $opt_insert_mode ;#default 1 - set autowrap_mode $opt_autowrap_mode ;#default 1 - set crm_mode $opt_crm_mode ;#default 0 (Show Control Character mode) - set reverse_mode $opt_reverse_mode - - #----- - # - if {[info exists punk::console::tabwidth]} { - #punk console is updated if punk::console::set_tabstop_width is used or rep is started/restarted - #It is way too slow to test the current width by querying the terminal here - so it could conceivably get out of sync - #todo - we also need to handle the new threaded repl where console config is in a different thread. - # - also - concept of sub-regions being mini-consoles with their own settings - 'id' for console, or use in/out channels as id? - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - - set overdata $over - if {!$cp437_glyphs} { - #REVIEW! tabify will give different answers for an ANSI colourised string vs plain text - if {!$opt_etabs} { - if {[string first \t $under] >= 0} { - #set under [textutil::tabify::untabify2 $under] - set under [textutil::tabify::untabifyLine $under $tw] - } - if {[string first \t $over] >= 0} { - #set overdata [textutil::tabify::untabify2 $over] - set overdata [textutil::tabify::untabifyLine $over $tw] - } - } - } - #------- - - #ta_detect ansi and do simpler processing? - - #we repeat tests for grapheme width in different loops - rather than create another datastructure to store widths based on column, - #we'll use the grapheme_width_cached function as a lookup table of all graphemes encountered - as there will often be repeats in different positions anyway. - - # -- --- --- --- --- --- --- --- - if {$under ne ""} { - if {[punk::ansi::ta::detect $under]} { - set undermap [punk::ansi::ta::split_codes_single $under] - } else { - #single plaintext part - set undermap [list $under] - } - } else { - set undermap [list] - } - set understacks [list] - set understacks_gx [list] - set pm_list [list] - - set i_u -1 ;#underlay may legitimately be empty - set undercols [list] - set u_codestack [list] - #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway - set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) - #set pt_underchars "" ;#for string_columns length calculation for expand_right 0 truncation - set remainder [list] ;#for returnextra - foreach {pt code} $undermap { - #pt = plain text - #append pt_underchars $pt - if {$pt ne ""} { - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - set is_ptrun 0 - if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { - set p1 [tcl::string::index $pt 0] - set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex - set re [tcl::string::cat {^[} \\U$hex {]+$}] - set is_ptrun [regexp $re $pt] - } - if {$is_ptrun} { - #switch -- $p1 { - # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - # a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - # z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - # set width 1 - # } - # default { - # if {$p1 eq "\u0000"} { - # #use null as empty cell representation - review - # #use of this will probably collide with some application at some point - # #consider an option to set the empty cell character - # set width 1 - # } else { - # set width [grapheme_width_cached $p1] ;# when zero??? - # } - # } - #} - set width [grapheme_width_cached $p1] ;# when zero??? - set ptlen [string length $pt] - if {$width <= 1} { - #review - 0 and 1? - incr i_u $ptlen - lappend understacks {*}[lrepeat $ptlen $u_codestack] - lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] - lappend undercols {*}[lrepeat $ptlen $p1] - } else { - incr i_u $ptlen ;#2nd col empty str - so same as above - set 2ptlen [expr {$ptlen * 2}] - lappend understacks {*}[lrepeat $2ptlen $u_codestack] - lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] - set l [concat {*}[lrepeat $ptlen [list $p1 ""]] - lappend undercols {*}$l - unset l - } - - } else { - foreach grapheme [punk::char::grapheme_split $pt] { - #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. - #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. - #todo - test decimal value instead, compare performance - switch -- $grapheme { - " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - set width 1 - } - default { - if {$grapheme eq "\u0000"} { - #use null as empty cell representation - review - #use of this will probably collide with some application at some point - #consider an option to set the empty cell character - set width 1 - } else { - #zero width still acts as 1 below??? review what should happen - set width [grapheme_width_cached $grapheme] - #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length - #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI - #todo - default to off and add a flag (?) to enable this substitution - set sub_stray_escapes 0 - if {$sub_stray_escapes && $width == 0} { - if {$grapheme eq "\x1b"} { - set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char.. - set grapheme $gvis - set width 1 - } - } - } - } - } - - #set width [grapheme_width_cached $grapheme] - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - - lappend undercols $grapheme - if {$width > 1} { - #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) - #but what about emoji combinations etc - can they be wider than 2? - #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - lappend undercols "" - } - } - - } - } - #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here - - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc - #keep any remaining PMs in place - if {$code ne ""} { - set c1c2 [tcl::string::range $code 0 1] - - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\( 7GFX\ - \x1b^ 7PMX\ - \x1bX 7SOS\ - ] $c1c2] 0 3];# leadernorm is 1st 2 chars mapped to normalised indicator - or is original 2 chars - - switch -- $leadernorm { - 7CSI - 8CSI { - #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse - #REVIEW - what else could end in m but be mistaken as a normal SGR code here? - set maybemouse "" - if {[tcl::string::index $c1c2 0] eq "\x1b"} { - set maybemouse [tcl::string::index $code 2] - } - - if {$maybemouse ne "<" && [tcl::string::index $code end] eq "m"} { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set u_codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set u_codestack [list $code] - } else { - #basic simplification first.. straight dups - set dup_posns [lsearch -all -exact $u_codestack $code] ;#-exact because of square-bracket glob chars - set u_codestack [lremove $u_codestack {*}$dup_posns] - lappend u_codestack $code - } - } - } - 7GFX { - switch -- [tcl::string::index $code 2] { - "0" { - set u_gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess - } - B { - set u_gx_stack [list] - } - } - } - 7PMX - 7SOS { - #we can have PMs or SOS (start of string) in the underlay - though mostly the PMs should have been processed.. - #attach the PM/SOS (entire ANSI sequence) to the previous grapheme! - #It should not affect the size - but terminal display may get thrown out if terminal doesn't support them. - - #note that there may in theory already be ANSI stored - we don't assume it was a pure grapheme string - set graphemeplus [lindex $undercols end] - if {$graphemeplus ne "\0"} { - append graphemeplus $code - } else { - set graphemeplus $code - } - lset undercols end $graphemeplus - #The grapheme_width_cached function will be called on this later - and doesn't account for ansi. - #we need to manually cache the item with it's proper width - variable grapheme_widths - #stripped and plus version keys pointing to same length - dict set grapheme_widths $graphemeplus [grapheme_width_cached [::punk::ansi::ansistrip $graphemeplus]] - - } - default { - - } - - } - - #if {[punk::ansi::codetype::is_sgr_reset $code]} { - # #set u_codestack [list] - #} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - #} elseif {[punk::ansi::codetype::is_sgr $code]} { - #} else { - # #leave SGR stack as is - # if {[punk::ansi::codetype::is_gx_open $code]} { - # } elseif {[punk::ansi::codetype::is_gx_close $code]} { - # } - #} - } - #consider also if there are other codes that should be stacked..? - } - - #NULL empty cell indicator - if {$opt_width ne "\uFFEF"} { - if {[llength $understacks]} { - set cs $u_codestack - set gs $u_gx_stack - } else { - set cs [list] - set gs [list] - } - if {[llength $undercols]< $opt_width} { - set diff [expr {$opt_width- [llength $undercols]}] - if {$diff > 0} { - #set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower - lappend undercols {*}[lrepeat $diff "\u0000"] - lappend understacks {*}[lrepeat $diff $cs] - lappend understacks_gx {*}[lrepeat $diff $gs] - } - } - } - - if {$opt_width ne "\uFFEF"} { - set renderwidth $opt_width - } else { - set renderwidth [llength $undercols] - } - - - if 0 { - # ----------------- - # if we aren't extending understacks & understacks_gx each time we incr idx above the undercols length.. this doesn't really serve a purpose - # Review. - # ----------------- - #replay code for last overlay position in input line - # whether or not we get that far - we need to return it for possible replay on next line - if {[llength $understacks]} { - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - } else { - #in case overlay onto emptystring as underlay - lappend understacks [list] - lappend understacks_gx [list] - } - # ----------------- - } - - #trailing codes in effect for underlay - if {[llength $u_codestack]} { - #set replay_codes_underlay [join $u_codestack ""] - set replay_codes_underlay [punk::ansi::codetype::sgr_merge_list {*}$u_codestack] - } else { - set replay_codes_underlay "" - } - - - # -- --- --- --- --- --- --- --- - #### - #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left containing the right number of columns. - #this will be processed as transparent - and handle doublewidth underlay characters appropriately - set startpadding [string repeat " " [expr {$opt_colstart -1}]] - #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency - if {$startpadding ne "" || $overdata ne ""} { - if {[punk::ansi::ta::detect $overdata]} { - set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] - } else { - #single plaintext part - set overmap [list $startpadding$overdata] - } - } else { - set overmap [list] - } - #### - - - #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) - #will that allow some optimisations? - - #todo - detect repeated transparent char in overlay - #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. - # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data - #we should be able to optimize to pass through the underlay?? - - #??? - set colcursor $opt_colstart - #TODO - make a little virtual column object - #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn - #need to lock-down what start column means from perspective of ANSI codes moving around - the offset perspective is unclear and a mess. - - - #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} - #as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes - - set overstacks [list] - set overstacks_gx [list] - - set o_codestack [list]; #SGR codestack (not other codes such as movement,insert key etc) - set o_gxstack [list] - set pt_overchars "" - set i_o 0 - set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use - #experiment - set overlay_grapheme_control_stacks [list] - foreach {pt code} $overmap { - if {$pt ne ""} { - #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - append pt_overchars $pt - #will get empty pt between adjacent codes - if {!$crm_mode} { - - set is_ptrun 0 - if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { - set p1 [tcl::string::index $pt 0] - set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] - set is_ptrun [regexp $re $pt] - - #leading only? we would have to check for graphemes at the trailing boundary? - #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] - #set is_ptrun [regexp -indices $re $pt runrange] - #if {$is_ptrun && 1} { - #} - } - if {$is_ptrun} { - #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) - #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) - set len [string length $pt] - set g_element [list g $p1] - - #lappend overstacks {*}[lrepeat $len $o_codestack] - #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] - #incr i_o $len - #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] - #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] - - set pi 0 - incr i_o $len - while {$pi < $len} { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - lappend overlay_grapheme_control_list $g_element - lappend overlay_grapheme_control_stacks $o_codestack - incr pi - } - } else { - foreach grapheme [punk::char::grapheme_split $pt] { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack - } - } - } else { - set tsbegin [clock micros] - foreach grapheme_original [punk::char::grapheme_split $pt] { - set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] - #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" - foreach grapheme [punk::char::grapheme_split $pt_crm] { - if {$grapheme eq "\n"} { - lappend overlay_grapheme_control_stacks $o_codestack - lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] - } else { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack - } - } - } - set elapsed [expr {[clock micros] - $tsbegin}] - puts stderr "ptlen [string length $pt] elapsedus:$elapsed" - } - } - - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc - #order of if-else based on assumptions: - # that pure resets are fairly common - more so than leading resets with other info - # that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. - if {$code ne ""} { - #we need to immediately set crm_mode here if \x1b\[3h received - if {$code eq "\x1b\[3h"} { - set crm_mode 1 - } elseif {$code eq "\x1b\[3l"} { - set crm_mode 0 - } - #else crm_mode could be set either way from options - if {$crm_mode && $code ne "\x1b\[00001E"} { - #treat the code as type 'g' like above - only allow through codes to reset mode REVIEW for now just \x1b\[3l ? - #we need to somehow convert further \n in the graphical rep to an instruction for newline that will bypass further crm_mode processing or we would loop. - set code_as_pt [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $code] - #split using standard split for first foreach loop - grapheme based split when processing 2nd foreach loop - set chars [split $code_as_pt ""] - set codeparts [list] ;#list of 2-el lists each element {crmcontrol } or {g } - foreach c $chars { - if {$c eq "\n"} { - #use CNL (cursor next line) \x1b\[00001E ;#leading zeroes ok for this processor - used as debugging aid to distinguish - lappend codeparts [list crmcontrol "\x1b\[00001E"] - } else { - if {[llength $codeparts] > 0 && [lindex $codeparts end 0] eq "g"} { - set existing [lindex $codeparts end 1] - lset codeparts end [list g [string cat $existing $c]] - } else { - lappend codeparts [list g $c] - } - } - } - - set partidx 0 - foreach record $codeparts { - lassign $record rtype rval - switch -exact -- $rtype { - g { - append pt_overchars $rval - foreach grapheme [punk::char::grapheme_split $rval] { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack - } - } - crmcontrol { - #leave o_codestack - lappend overlay_grapheme_control_stacks $o_codestack - lappend overlay_grapheme_control_list [list crmcontrol $rval] - } - } - } - } else { - lappend overlay_grapheme_control_stacks $o_codestack - #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set o_codestack [list $code] - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[priv::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $o_codestack $code] ;#must be -exact because of square-bracket glob chars - set o_codestack [lremove $o_codestack {*}$dup_posns] - lappend o_codestack $code - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[regexp {\x1b7|\x1b\[s} $code]} { - #experiment - #cursor_save - for the replays review. - #jmn - #set temp_cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] - lappend overlay_grapheme_control_list [list other $code] - } elseif {[regexp {\x1b8|\x1b\[u} $code]} { - #experiment - #cursor_restore - for the replays - set o_codestack [list $temp_cursor_saved] - lappend overlay_grapheme_control_list [list other $code] - } else { - #review - if {[punk::ansi::codetype::is_gx_open $code]} { - set o_gxstack [list "gx0_on"] - lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } elseif {[punk::ansi::codetype::is_gx_close $code]} { - set o_gxstack [list] - lappend overlay_grapheme_control_list [list gx0 gx0_off] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } else { - lappend overlay_grapheme_control_list [list other $code] - } - } - } - } - - } - #replay code for last overlay position in input line - should take account of possible trailing sgr code after last grapheme - set max_overlay_grapheme_index [expr {$i_o -1}] - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - - #set replay_codes_overlay [join $o_codestack ""] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] - - #if {[tcl::dict::exists $overstacks $max_overlay_grapheme_index]} { - # set replay_codes_overlay [join [tcl::dict::get $overstacks $max_overlay_grapheme_index] ""] - #} else { - # set replay_codes_overlay "" - #} - # -- --- --- --- --- --- --- --- - - - #potential problem - combinining diacritics directly following control chars like \r \b - - # -- --- --- - #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 - if {$opt_expand_right} { - #expand_right true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. - #we currently only support horizontal expansion to the right (review regarding RTL text!) - set overflow_idx -1 - } else { - #expand_right zero - we can't grow beyond our column width - so we get ellipsis or truncation - if {$opt_width ne "\uFFEF"} { - set overflow_idx [expr {$opt_width}] - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - } - # -- --- --- - - set outcols $undercols ;#leave undercols as is, outcols can potentially be appended to. - - set unapplied "" ;#if we break for move row (but not for /v ?) - set unapplied_list [list] - - set insert_lines_above 0 ;#return key - set insert_lines_below 0 - set instruction "" - - # -- --- --- - #cursor_save_dec, cursor_restore_dec etc - set cursor_restore_required 0 - set cursor_saved_attributes "" - set cursor_saved_position "" - # -- --- --- - - #set idx 0 ;# line index (cursor - 1) - #set idx [expr {$opt_colstart + $opt_colcursor} -1] - - #idx is the per column output index - set idx [expr {$opt_colcursor -1}] ;#don't use opt_colstart here - we have padded and won't start emitting until idx reaches opt_colstart-1 - #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. - #(for now we are incrementing/decrementing both in sync - which is a bit silly) - set cursor_column $opt_colcursor - - #idx_over is the per grapheme overlay index - set idx_over -1 - - - #movements only occur within the overlay range. - #an underlay is however not necessary.. e.g - #renderline -expand_right 1 "" data - - #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM - #set re_col_move {\x1b\[([0-9]*)(C|D|G)$} - #set re_row_move {\x1b\[([0-9]*)(A|B)$} - #set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ? - #set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} - #set re_cursor_save {\x1b\[s$} ;#note probable incompatibility with DECSLRM (set left right margin)! - #set re_cursor_restore {\x1b\[u$} - #set re_cursor_save_dec {\x1b7$} - #set re_cursor_restore_dec {\x1b8$} - #set re_other_single {\x1b(D|M|E)$} - #set re_decstbm {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)r$} ;#DECSTBM set top and bottom margins - - #puts "-->$overlay_grapheme_control_list<--" - #puts "-->overflow_idx: $overflow_idx" - for {set gci 0} {$gci < [llength $overlay_grapheme_control_list]} {incr gci} { - set gc [lindex $overlay_grapheme_control_list $gci] - lassign $gc type item - - #emit plaintext chars first using existing SGR codes from under/over stack as appropriate - #then check if the following code is a cursor movement within the line and adjust index if so - #foreach ch $overlay_graphemes {} - switch -- $type { - g { - set ch $item - #crm_mode affects both graphic and control - if {0 && $crm_mode} { - set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] - set chars [string map [list \n "\x1b\[00001E"] $chars] - if {[llength [split $chars ""]] > 1} { - priv::render_unapplied $overlay_grapheme_control_list $gci - #prefix the unapplied controls with the string version of this control - set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] - set unapplied [join $unapplied_list ""] - #incr idx_over - break - } else { - set ch $chars - } - } - incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. - if {($idx < ($opt_colstart -1))} { - incr idx [grapheme_width_cached $ch] - continue - } - #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width - set within_undercols [expr {$idx <= $renderwidth-1}] - - #https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters - #\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline, - #on some it's invisble but doesn't change the line, on some it's a visible glyph of width 1. - #This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable - #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE - - set chtest [tcl::string::map [list \n \x85 \b \r \v \x7f ] $ch] - #puts --->chtest:$chtest - #specials - each shoud have it's own test of what to do if it happens after overflow_idx reached - switch -- $chtest { - "" { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - if {$idx == 0} { - #puts "---a at col 1" - #linefeed at column 1 - #leave the overflow_idx ;#? review - set instruction lf_start ;#specific instruction for newline at column 1 - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { - #linefeed after final column - #puts "---c at overflow_idx=$overflow_idx" - incr cursor_row - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 - set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } else { - #linefeed occurred in middle or at end of text - #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" - if {$insert_mode == 0} { - incr cursor_row - if {$idx == -1 || $overflow_idx > $idx} { - #don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 - } - set instruction lf_mid - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } else { - incr cursor_row - #don't adjust the overflow_idx - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction lf_mid - break ;# could have overdata following the \n - don't keep processing - } - } - - } - "" { - #will we want/need to use raw for keypresses in terminal? (terminal with LNM in standard reset mode means enter= this is the usual config for terminals) - #So far we are assuming the caller has translated to and handle above.. REVIEW. - - #consider also the old space-carriagereturn softwrap convention used in some terminals. - #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. - set idx [expr {$opt_colstart -1}] - set cursor_column $opt_colstart ;#? - } - "" { - #literal backspace char - not necessarily from keyboard - #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype - #(important for -transparent option - hence replacement chars for half-exposed etc) - #review - overstrike support as per nroff/less (generally considered an old technology replaced by unicode mechanisms and/or ansi SGR) - if {$idx > ($opt_colstart -1)} { - incr idx -1 - incr cursor_column -1 - } else { - set flag 0 - if $flag { - #review - conflicting requirements? Need a different sequence for destructive interactive backspace? - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction backspace_at_start - break - } - } - } - "" { - #literal del character - some terminals send just this for what is generally expected to be a destructive backspace - #We instead treat this as a pure delete at current cursor position - it is up to the repl or terminal to remap backspace key to a sequence that has the desired effect. - priv::render_delchar $idx - } - "" { - #end processing this overline. rest of line is remainder. cursor for column as is. - #REVIEW - this theoretically depends on terminal's vertical tabulation setting (name?) - #e.g it could be configured to jump down 6 rows. - #On the other hand I've seen indications that some modern terminal emulators treat it pretty much as a linefeed. - #todo? - incr cursor_row - set overflow_idx $idx - #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction vt - break - } - default { - if {$overflow_idx != -1} { - #review - how to check arbitrary length item such as tab is going to overflow .. before we get to overflow_idx? - #call grapheme_width_cached on each ch, or look for tab specifically as it's currently the only known reason to have a grapheme width > 2? - #we need to decide what a tab spanning the overflow_idx means and how it affects wrap etc etc - if {$idx == $overflow_idx-1} { - set owidth [grapheme_width_cached $ch] - if {$owidth == 2} { - #review split 2w overflow? - #we don't want to make the decision here to split a 2w into replacement characters at end of line and beginning of next line - #better to consider the overlay char as unable to be applied to the line - #render empty column(?) - and reduce overlay grapheme index by one so that the current ch goes into unapplied - #throwing back to caller with instruction complicates its job - but is necessary to avoid making decsions for it here. - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #change the overflow_idx - set overflow_idx $idx - incr idx - incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used - priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci - #throw back to caller's loop - add instruction to caller as this is not the usual case - #caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line - set instruction overflow_splitchar - break - } elseif {$owidth > 2} { - #? tab? - #TODO! - puts stderr "overtype::renderline long overtext grapheme '[ansistring VIEW -lf 1 -vt 1 $ch]' not handled" - #tab of some length dependent on tabstops/elastic tabstop settings? - } - } elseif {$idx >= $overflow_idx} { - #REVIEW - set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control - lassign $next_gc next_type next_item - if {$autowrap_mode || $next_type ne "g"} { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] - #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #don't incr idx beyond the overflow_idx - #idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied - incr idx_over -1 - #priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too - priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# - set instruction overflow - break - } else { - #no point throwing back to caller for each grapheme that is overflowing - #without this branch - renderline would be called with overtext reducing only by one grapheme per call - #processing a potentially long overtext each time (ie - very slow) - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #JMN4 - - } - } - } else { - #review. - #overflow_idx = -1 - #This corresponds to expand_right being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) - } - - if {($do_transparency && [regexp $opt_transparent $ch])} { - #pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) - if {$idx > [llength $outcols]-1} { - lappend outcols " " - #tcl::dict::set understacks $idx [list] ;#review - use idx-1 codestack? - #lset understacks $idx [list] ;#will get index $i out of range error - lappend understacks [list] ;#REVIEW - incr idx - incr cursor_column - } else { - #todo - punk::char::char_width - set g [lindex $outcols $idx] - #JMN - set uwidth [grapheme_width_cached $g] - if {[lindex $outcols $idx] eq ""} { - #2nd col of 2-wide char in underlay - incr idx - incr cursor_column - } elseif {$uwidth == 0} { - #e.g control char ? combining diacritic ? - incr idx - incr cursor_column - } elseif {$uwidth == 1} { - set owidth [grapheme_width_cached $ch] - incr idx - incr cursor_column - if {$owidth > 1} { - incr idx - incr cursor_column - } - } elseif {$uwidth > 1} { - if {[grapheme_width_cached $ch] == 1} { - if {!$insert_mode} { - #normal singlewide transparent overlay onto double-wide underlay - set next_pt_overchar [tcl::string::index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay - if {$next_pt_overchar eq ""} { - #special-case trailing transparent - no next_pt_overchar - incr idx - incr cursor_column - } else { - if {[regexp $opt_transparent $next_pt_overchar]} { - incr idx - incr cursor_column - } else { - #next overlay char is not transparent.. first-half of underlying 2wide char is exposed - #priv::render_addchar $idx $opt_exposed1 [tcl::dict::get $overstacks $idx_over] [tcl::dict::get $overstacks_gx $idx_over] $insert_mode - priv::render_addchar $idx $opt_exposed1 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } - } else { - #? todo - decide what transparency even means for insert mode - incr idx - incr cursor_column - } - } else { - #2wide transparency over 2wide in underlay - review - incr idx - incr cursor_column - } - } - } - } else { - - set idxchar [lindex $outcols $idx] - #non-transparent char in overlay or empty cell - if {$idxchar eq "\u0000"} { - #empty/erased cell indicator - set uwidth 1 - } else { - set uwidth [grapheme_width_cached $idxchar] - } - if {$within_undercols} { - if {$idxchar eq ""} { - #2nd col of 2wide char in underlay - if {!$insert_mode} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 - #JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme - #e.g renderline \uFF21\uFF21--- a\uFF23\uFF23 - #vs - # renderline -startcolumn 2 \uFF21---- \uFF23 - if {[lindex $outcols $idx-1] != ""} { - #verified it's an empty following a filled - so it's a legit underlay remnant (REVIEW - when would it not be??) - #reset previous to an exposed 1st-half - but leave understacks code as is - priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 - } - incr idx - } else { - set prevcolinfo [lindex $outcols $idx-1] - #for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right - #REVIEW - this leaves a replacement character permanently in our columns.. but it is consistent regarding length (?) - #The alternative is to disallow insertion at a column cursor that is at 2nd half of 2wide char - #perhaps by inserting after the char - this may be worthwhile - but may cause other surprises - #It is perhaps best avoided at another level and try to make renderline do exactly as it's told - #the advantage of this 2w splitting method is that the inserted character ends up in exactly the column we expect. - priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 ;#replace not insert - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 1 ;#insert - same index - if {$prevcolinfo ne ""} { - #we've split the 2wide - it may already have been rendered as an exposed1 - but not for example if our startcolumn was current idx - priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 ;#replace not insert - } ;# else?? - incr idx - } - if {$cursor_column < [llength $outcols] || $overflow_idx == -1} { - incr cursor_column - } - } elseif {$uwidth == 0} { - #what if this is some other c0/c1 control we haven't handled specifically? - - #by emitting a preceding empty-string column - we associate whatever this char is with the preceeding non-zero-length character and any existing zero-lengths that follow it - #e.g combining diacritic - increment before over char REVIEW - #arguably the previous overchar should have done this - ie lookahead for combiners? - #if we can get a proper grapheme_split function - this should be easier to tidy up. - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column 2 - - if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { - set cursor_column [llength $outcols] - } - } elseif {$uwidth == 1} { - #includes null empty cells - set owidth [grapheme_width_cached $ch] - if {$owidth == 1} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - } else { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #if next column in underlay empty - we've overwritten first half of underlying 2wide grapheme - #replace with rhs exposure in case there are no more overlay graphemes coming - use underlay's stack - if {([llength $outcols] >= $idx +2) && [lindex $outcols $idx+1] eq ""} { - priv::render_addchar [expr {$idx+1}] $opt_exposed2 [lindex $understacks $idx+1] [lindex $understacks_gx $idx+1] $insert_mode - } - incr idx - } - if {($cursor_column < [llength $outcols]) || $overflow_idx == -1} { - incr cursor_column - } - } elseif {$uwidth > 1} { - set owidth [grapheme_width_cached $ch] - if {$owidth == 1} { - #1wide over 2wide in underlay - if {!$insert_mode} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char - } else { - #insert mode just pushes all to right - no exposition char here - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } else { - #2wide over 2wide - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx 2 - incr cursor_column 2 - } - - if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { - set cursor_column [llength $outcols] - } - } - } else { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } - } - } ;# end switch - - - } - other - crmcontrol { - if {$crm_mode && $type ne "crmcontrol" && $item ne "\x1b\[00001E"} { - if {$item eq "\x1b\[3l"} { - set crm_mode 0 - } else { - #When our initial overlay split was done - we weren't in crm_mode - so there are codes that weren't mapped to unicode control character representations - #set within_undercols [expr {$idx <= $renderwidth-1}] - #set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $item] - set chars [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $item] - priv::render_unapplied $overlay_grapheme_control_list $gci - #prefix the unapplied controls with the string version of this control - set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] - set unapplied [join $unapplied_list ""] - - break - } - } - - #todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that. - #we should possibly therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore? - set code [tcl::string::map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $item] - #since this element isn't a grapheme - advance idx_over to next grapheme overlay when about to fill 'unapplied' - - - #remap of DEC cursor_save/cursor_restore from ESC sequence to equivalent CSI - #probably not ideal - consider putting cursor_save/cursor_restore in functions so they can be called from the appropriate switch branch instead of using this mapping - #review - cost/benefit of function calls within these switch-arms instead of inline code? - - set c1 [tcl::string::index $code 0] - set c1c2c3 [tcl::string::range $code 0 2] - #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} - #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. - #(somewhat surprising) - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[< 1006\ - \x1b\[ 7CSI\ - \x1bY 7MAP\ - \x1bP 7DCS\ - \x90 8DCS\ - \x9b 8CSI\ - \x1b\] 7OSC\ - \x9d 8OSC\ - \x1b 7ESC\ - ] $c1c2c3] 0 3] ;#leadernorm is 1st 1,2 or 3 chars mapped to 4char normalised indicator - or is original first chars (1,2 or 3 len) - - #we leave the tail of the code unmapped for now - switch -- $leadernorm { - 1006 { - #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html - #SGR (1006) CSI < followed by colon separated encoded-button-value,px,py ordinates and final M for button press m for button release - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] - } - 7CSI - 7OSC { - #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] - set codenorm $leadernorm[tcl::string::range $code 2 end] - } - 7DCS { - #ESC P - #Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74 - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] - } - 8DCS { - #8-bit Device Control String - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - 7MAP { - #map to another type of code to share implementation branch - set codenorm $leadernorm[tcl::string::range $code 1 end] - } - 7ESC { - #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - set codenorm $leadernorm[tcl::string::range $code 1 end] - } - 8CSI - 8OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - default { - puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - #we haven't made a mapping for this - #could in theory be 1,2 or 3 in len - #although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches - set codenorm $code - } - } - - switch -- $leadernorm { - 7MAP { - switch -- [lindex $codenorm 4] { - Y { - #vt52 movement. we expect 2 chars representing position (limited range) - set params [tcl::string::range $codenorm 5 end] - if {[tcl::string::length $params] != 2} { - #shouldn't really get here or need this branch if ansi splitting was done correctly - puts stderr "overtype::renderline ESC Y recognised as vt52 move, but incorrect parameters length ([string length $params] vs expected 2) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" - } - set line [tcl::string::index $params 5] - set column [tcl::string::index $params 1] - set r [expr {[scan $line %c] -31}] - set c [expr {[scan $column %c] -31}] - - #MAP to: - #CSI n;m H - CUP - Cursor Position - set leadernorm 7CSI - set codenorm "$leadernorm${r}\;${c}H" - } - } - } - } - - #we've mapped 7 and 8bit escapes to values we can handle as literals in switch statements to take advantange of jump tables. - switch -- $leadernorm { - 1006 { - #TODO - # - switch -- [tcl::string::index $codenorm end] { - M { - puts stderr "mousedown $codenorm" - } - m { - puts stderr "mouseup $codenorm" - } - } - - } - {7CSI} - {8CSI} { - set param [tcl::string::range $codenorm 4 end-1] - #puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param" - set code_end [tcl::string::index $codenorm end] ;#used for e.g h|l set/unset mode - - switch -exact -- $code_end { - A { - #Row move - up - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #todo - lassign [split $param {;}] num modifierkey - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - - if {$num eq ""} {set num 1} - incr cursor_row -$num - - if {$cursor_row < 1} { - set cursor_row 1 - } - - #ensure rest of *overlay* is emitted to remainder - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction up - #retain cursor_column - break - } - B { - #CUD - Cursor Down - #Row move - down - lassign [split $param {;}] num modifierkey - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move down - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - if {$num eq ""} {set num 1} - incr cursor_row $num - - - incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction down - #retain cursor_column - break - } - C { - #CUF - Cursor Forward - #Col move - #puts stdout "->forward" - #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. - #cursor forward - #right-arrow/move forward - lassign [split $param {;}] num modifierkey - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - if {$num eq ""} {set num 1} - - #todo - retrict to moving 1 position past datalen? restrict to column width? - #should ideally wrap to next line when interactive and not on last row - #(some ansi art seems to expect this behaviour) - #This presumably depends on the terminal's wrap mode - #e.g DECAWM autowrap mode - # CSI ? 7 h - set: autowrap (also tput smam) - # CSI ? 7 l - reset: no autowrap (also tput rmam) - set version 2 - if {$version eq "2"} { - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$cursor_column == $max+1} { - #move_forward while in overflow - incr cursor_column -1 - } - - if {($cursor_column + $num) <= $max} { - incr idx $num - incr cursor_column $num - } else { - if {$autowrap_mode} { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #jmn - if {$idx == $overflow_idx} { - incr num - } - - #horizontal movement beyond line extent needs to wrap - throw back to caller - #we may have both overflow_right and unapplied data - #(can have overflow_right if we were in insert_mode and processed chars prior to this movement) - #leave row as is - caller will need to determine how many rows the column-movement has consumed - incr cursor_column $num ;#give our caller the necessary info as columns from start of row - #incr idx_over - #should be gci following last one applied - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction wrapmoveforward - break - } else { - set cursor_column $max - set idx [expr {$cursor_column -1}] - } - } - } else { - #review - dead branch - if {!$expand_right || ($cursor_column + $num) <= [llength $outcols+1]} { - incr idx $num - incr cursor_column $num - } else { - if {!$insert_mode} { - #block editing style with arrow keys - #overtype mode - set idxstart $idx - set idxend [llength $outcols] - set moveend [expr {$idxend - $idxstart}] - if {$moveend < 0} {set moveend 0} ;#sanity? - #puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]" - incr idx $moveend - incr cursor_column $moveend - #if {[tcl::dict::exists $understacks $idx]} { - # set stackinfo [tcl::dict::get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext - #} else { - # set stackinfo [list] - #} - if {$idx < [llength $understacks]} { - set stackinfo [lindex $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext - } else { - set stackinfo [list] - } - if {$idx < [llength $understacks_gx]} { - #set gxstackinfo [tcl::dict::get $understacks_gx $idx] - set gxstackinfo [lindex $understacks_gx $idx] - } else { - set gxstackinfo [list] - } - #pad outcols - set movemore [expr {$num - $moveend}] - #assert movemore always at least 1 or we wouldn't be in this branch - for {set m 1} {$m <= $movemore} {incr m} { - incr idx - incr cursor_column - priv::render_addchar $idx " " $stackinfo $gxstackinfo $insert_mode - } - } else { - #normal - insert - incr idx $num - incr cursor_column $num - if {$idx > [llength $outcols]} { - set idx [llength $outcols];#allow one beyond - for adding character at end of line - set cursor_column [expr {[llength $outcols]+1}] - } - } - } - } - } - D { - #Col move - #puts stdout "<-back" - #cursor back - #left-arrow/move-back when ltr mode - lassign [split $param {;}] num modifierkey - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - if {$num eq ""} {set num 1} - - set version 2 - if {$version eq "2"} { - #todo - startcolumn offset! - if {$cursor_column - $num >= 1} { - incr idx -$num - incr cursor_column -$num - } else { - if {!$autowrap_mode} { - set cursor_column 1 - set idx 0 - } else { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr cursor_column -$num - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction wrapmovebackward - break - } - } - } else { - incr idx -$num - incr cursor_column -$num - if {$idx < $opt_colstart-1} { - #wrap to previous line and position cursor at end of data - set idx [expr {$opt_colstart-1}] - set cursor_column $opt_colstart - } - } - } - E { - #CNL - Cursor Next Line - if {$param eq ""} { - set downmove 1 - } else { - set downmove [expr {$param}] - } - puts stderr "renderline CNL down-by-$downmove" - set cursor_column 1 - set cursor_row [expr {$cursor_row + $downmove}] - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - - } - F { - #CPL - Cursor Previous Line - if {$param eq ""} { - set upmove 1 - } else { - set upmove [expr {$param}] - } - puts stderr "renderline CPL up-by-$upmove" - set cursor_column 1 - set cursor_row [expr {$cursor_row -$upmove}] - if {$cursor_row < 1} { - set cursor_row 1 - } - set idx [expr {$cursor_column - 1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - - } - G { - #CHA - Cursor Horizontal Absolute (move to absolute column no) - if {$param eq ""} { - set targetcol 1 - } else { - set targetcol $param - if {![string is integer -strict $targetcol]} { - puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Unrecognised parameter '$param'" - } - set targetcol [expr {$param}] - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$targetcol > $max} { - puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Param '$param' > max: $max" - set targetcol $max - } - } - #adjust to colstart - as column 1 is within overlay - #??? REVIEW - set idx [expr {($targetcol -1) + $opt_colstart -1}] - - - set cursor_column $targetcol - #puts stderr "renderline absolute col move ESC G (TEST)" - } - H - f { - #CSI n;m H - CUP - Cursor Position - - #CSI n;m f - HVP - Horizontal Vertical Position REVIEW - same as CUP with differences (what?) in some terminal modes - # - 'counts as effector format function (like CR or LF) rather than an editor function (like CUD or CNL)' - # - REVIEW - #see Annex A at: https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf - - #test e.g ansicat face_2.ans - #$re_both_move - lassign [split $param {;}] paramrow paramcol - #missing defaults to 1 - #CSI ;5H = CSI 1;5H -> row 1 col 5 - #CSI 17;H = CSI 17H = CSI 17;1H -> row 17 col 1 - - if {$paramcol eq ""} {set paramcol 1} - if {$paramrow eq ""} {set paramrow 1} - if {![string is integer -strict $paramcol] || ![string is integer -strict $paramrow]} { - puts stderr "renderline CUP (CSI H) unrecognised param $param" - #ignore? - } else { - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$paramcol > $max} { - set target_column $max - } else { - set target_column [expr {$paramcol}] - } - - - if {$paramrow < 1} { - puts stderr "renderline CUP (CSI H) bad row target 0. Assuming 1" - set target_row 1 - } else { - set target_row [expr {$paramrow}] - } - if {$target_row == $cursor_row} { - #col move only - no need for break and move - #puts stderr "renderline CUP col move only to col $target_column param:$param" - set cursor_column $target_column - set idx [expr {$cursor_column -1}] - } else { - set cursor_row $target_row - set cursor_column $target_column - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - } - } - } - J { - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? - switch -exact -- $modegroup { - ? { - #CSI ? Pn J - selective erase - puts stderr "overtype::renderline ED - SELECTIVE ERASE IN DISPLAY (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - default { - puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of screen - } - 1 { - #clear from cursor to beginning of screen - } - 2 { - #clear entire screen - #ansi.sys - move cursor to upper left REVIEW - set cursor_row 1 - set cursor_column 1 - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - if {[llength $outcols]} { - priv::render_erasechar 0 [llength $outcols] - } - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction clear_and_move - break - } - 3 { - #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? - - } - default { - } - } - - } - } - } - K { - #see DECECM regarding background colour - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? - switch -exact -- $modegroup { - ? { - puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - set param [string range $param 1 end] ;#chop qmark - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of line - depending on DECSCA - } - 1 { - #clear from cursor to beginning of line - depending on DECSCA - - } - 2 { - #clear entire line - depending on DECSCA - } - default { - puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - default { - puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of line - } - 1 { - #clear from cursor to beginning of line - - } - 2 { - #clear entire line - } - default { - puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - } - } - } - L { - puts stderr "overtype::renderline IL - Insert Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - M { - #CSI Pn M - DL - Delete Line - puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - - } - T { - #CSI Pn T - SD Pan Up (empty lines introduced at top) - #CSI Pn+T - kitty extension (lines at top come from scrollback buffer) - #Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display - if {$param eq "" || $param eq "0"} {set param 1} - if {[string index $param end] eq "+"} { - puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } else { - puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - X { - puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param" - #ECH - erase character - if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase - priv::render_erasechar $idx $param - #cursor position doesn't change. - } - q { - set code_secondlast [tcl::string::index $codenorm end-1] - switch -exact -- $code_secondlast { - {"} { - #DECSCA - Select Character Protection Attribute - #(for use with selective erase: DECSED and DECSEL) - set param [tcl::string::range $codenorm 4 end-2] - if {$param eq ""} {set param 0} - #TODO - store like SGR in stacks - replays? - switch -exact -- $param { - 0 - 2 { - #canerase - puts stderr "overtype::renderline - DECSCA canerase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - 1 { - #cannoterase - puts stderr "overtype::renderline - DECSCA cannoterase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - default { - puts stderr "overtype::renderline DECSCA param '$param' not understood [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - default { - puts stderr "overtype::renderline - CSI ... q not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - r { - #$re_decstbm - #https://www.vt100.net/docs/vt510-rm/DECSTBM.html - #This control function sets the top and bottom margins for the current page. You cannot perform scrolling outside the margins - lassign [split $param {;}] margin_top margin_bottom - - #todo - return these for the caller to process.. - puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented" - #Also moves the cursor to col 1 line 1 of the page - set cursor_column 1 - set cursor_row 1 - - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move ;#own instruction? decstbm? - break - } - s { - #code conflict between ansi emulation and DECSLRM - REVIEW - #ANSISYSSC (when no parameters) - like other terminals - essentially treat same as DECSC - # todo - when parameters - support DECSLRM instead - - if {$param ne ""} { - #DECSLRM - should only be recognised if DECLRMM is set (vertical split screen mode) - lassign [split $param {;} margin_left margin_right - puts stderr "overtype DECSLRM not yet supported - got [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$margin_left eq ""} { - set margin_left 1 - } - set columns_per_page 80 ;#todo - set to 'page width (DECSCPP set columns per page)' - could be 132 or?? - if {$margin_right eq ""} { - set margin_right $columns_per_page - } - puts stderr "DECSLRM margin left: $margin_left margin right: $margin_right" - if {![string is integer -strict $margin_left] || $margin_left < 0} { - puts stderr "DECSLRM invalid margin_left" - } - if {![string is integer -strict $margin_right] || $margin_right < 0} { - puts stderr "DECSLRM invalid margin_right" - } - set scrolling_region_size [expr {$margin_right - $margin_left}] - if {$scrolling_region_size < 2 || $scrolling_region_size > $columns_per_page} { - puts stderr "DECSLRM region size '$scrolling_regsion_size' must be between 1 and $columns_per_page" - } - #todo - - - } else { - #DECSC - #//notes on expected behaviour: - #DECSC - saves following items in terminal's memory - #cursor position - #character attributes set by the SGR command - #character sets (G0,G1,G2 or G3) currently in GL and GR - #Wrap flag (autowrap or no autowrap) - #State of origin mode (DECOM) - #selective erase attribute - #any single shift 2 (SS2) or single shift 3(SSD) functions sent - - #$re_cursor_save - #cursor save could come after last column - if {$overflow_idx != -1 && $idx == $overflow_idx} { - #bartman2.ans test file - fixes misalignment at bottom of dialog bubble - #incr cursor_row - #set cursor_column 1 - #bwings1.ans test file - breaks if we actually incr cursor (has repeated saves) - set cursor_saved_position [list row [expr {$cursor_row+1}] column 1] - } else { - set cursor_saved_position [list row $cursor_row column $cursor_column] - } - #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. - #we need the SGR and gx overlay codes prior to the cursor_save - - #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. - #set sgr_stack [lindex $understacks $idx] - #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) - - set sgr_stack [list] - set gx_stack [list] - - #we shouldn't need to scan for intermediate cursor save/restores - as restores would throw-back to the calling loop - so our overlay 'line' is since those. - #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. - - foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { - lassign $gc type code - #types g other sgr gx0 - switch -- $type { - gx0 { - #code is actually a stand-in for the graphics on/off code - not the raw code - #It is either gx0_on or gx0_off - set gx_stack [list $code] - } - sgr { - #code is the raw code - if {[punk::ansi::codetype::is_sgr_reset $code]} { - #jmn - set sgr_stack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set sgr_stack [list $code] - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[priv::is_sgr $code]} { - #often we don't get resets - and codes just pile up. - #as a first step to simplifying - at least remove earlier straight up dupes - set dup_posns [lsearch -all -exact $sgr_stack $code] ;#needs -exact - codes have square-brackets (glob chars) - set sgr_stack [lremove $sgr_stack {*}$dup_posns] - lappend sgr_stack $code - } - } - } - } - set cursor_saved_attributes "" - switch -- [lindex $gx_stack 0] { - gx0_on { - append cursor_saved_attributes "\x1b(0" - } - gx0_off { - append cursor_saved_attributes "\x1b(B" - } - } - #append cursor_saved_attributes [join $sgr_stack ""] - append cursor_saved_attributes [punk::ansi::codetype::sgr_merge_list {*}$sgr_stack] - - #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. - - #don't incr index - or the save will cause cursor to move to the right - #carry on - } - } - u { - #ANSISYSRC save cursor (when no parameters) (DECSC) - - #$re_cursor_restore - #we are going to jump somewhere.. for now we will assume another line, and process accordingly. - #The caller has the cursor_saved_position/cursor_saved_attributes if any (?review - if we always pass it back it, we could save some calls for moves in same line) - #don't set overflow at this point. The existing underlay to the right must be preserved. - #we only want to jump and render the unapplied at the new location. - - #lset overstacks $idx_over [list] - #set replay_codes_overlay "" - - #if {$cursor_saved_attributes ne ""} { - # set replay_codes_overlay $cursor_saved_attributes ;#empty - or last save if it happend in this input chunk - #} else { - #jj - #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set replay_codes_overlay "" - #} - - #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code - incr idx_over - - set unapplied "" - set unapplied_list [list] - foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { - lassign $gc type item - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - #incr idx_over - } - set unapplied [join $unapplied_list ""] - #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. - set instruction restore_cursor - break - } - "{" { - - puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" - } - "}" { - set code_secondlast [tcl::string::index $codenorm end-1] - switch -exact -- $code_secondlast { - ' { - puts stderr "renderline warning - DECIC - Insert Column - CSI...' - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" - } - default { - puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" - } - } - } - ~ { - set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ - switch -exact -- $code_secondlast { - ' { - #DECDC - editing sequence - Delete Column - puts stderr "renderline warning - DECDC - unimplemented" - } - default { - #$re_vt_sequence - lassign [split $param {;}] key mod - - #Note that f1 to f4 show as ESCOP|Q|R|S (VT220?) but f5+ show as ESC\[15~ - # - #e.g esc \[2~ insert esc \[2;2~ shift-insert - #mod - subtract 1, and then use bitmask - #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) - #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" - if {$key eq "1"} { - #home - } elseif {$key eq "2"} { - #Insert - if {$mod eq ""} { - #no modifier key - set insert_mode [expr {!$insert_mode}] - #rather than set the cursor - we return the insert mode state so the caller can decide - } - } elseif {$key eq "3"} { - #Delete - presumably this shifts other chars in the line, with empty cells coming in from the end - switch -- $mod { - "" { - priv::render_delchar $idx - } - "5" { - #ctrl-del - delete to end of word (pwsh) - possibly word on next line if current line empty(?) - } - } - } elseif {$key eq "4"} { - #End - } elseif {$key eq "5"} { - #pgup - } elseif {$key eq "6"} { - #pgDn - } elseif {$key eq "7"} { - #Home - #?? - set idx [expr {$opt_colstart -1}] - set cursor_column 1 - } elseif {$key eq "8"} { - #End - } elseif {$key eq "11"} { - #F1 - or ESCOP or e.g shift F1 ESC\[1;2P - } elseif {$key eq "12"} { - #F2 - or ESCOQ - } elseif {$key eq "13"} { - #F3 - or ESCOR - } elseif {$key eq "14"} { - #F4 - or ESCOS - } elseif {$key eq "15"} { - #F5 or shift F5 ESC\[15;2~ - } elseif {$key eq "17"} { - #F6 - } elseif {$key eq "18"} { - #F7 - } elseif {$key eq "19"} { - #F8 - } elseif {$key eq "20"} { - #F9 - } elseif {$key eq "21"} { - #F10 - } elseif {$key eq "23"} { - #F11 - } elseif {$key eq "24"} { - #F12 - } - - } - } - - } - h - l { - #set mode unset mode - #we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle? - - #$re_mode if first after CSI is "?" - #some docs mention ESC=h|l - not seen on windows terminals.. review - #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? = - switch -exact -- $modegroup { - ? { - set smparams [tcl::string::range $codenorm 5 end-1] ;#params between ? and h|l - #one or more modes can be set - set smparam_list [split $smparams {;}] - foreach num $smparam_list { - switch -- $num { - "" { - #ignore empties e.g extra/trailing semicolon in params - } - 5 { - #DECSNM - reverse video - #How we simulate this to render within a block of text is an open question. - #track all SGR stacks and constantly flip based on the current SGR reverse state? - #It is the job of the calling loop to do this - so at this stage we'll just set the states - - if {$code_end eq "h"} { - #set (enable) - set reverse_mode 1 - } else { - #reset (disable) - set reverse_mode 0 - } - - } - 7 { - #DECAWM autowrap - if {$code_end eq "h"} { - #set (enable) - set autowrap_mode 1 - if {$opt_width ne "\uFFEF"} { - set overflow_idx $opt_width - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? - # presume not usually - but sanity check with warning for now. - if {$idx >= $overflow_idx} { - puts stderr "renderline warning - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" - } - } else { - #reset (disable) - set autowrap_mode 0 - #REVIEW! - set overflow_idx -1 - } - } - 25 { - if {$code_end eq "h"} { - #visible cursor - - } else { - #invisible cursor - - } - } - 117 { - #DECECM - Erase Color Mode - #https://invisible-island.net/ncurses/ncurses.faq.html - #The Erase color selection controls the background color used when text is erased or new - #text is scrolled on to the screen. Screen background causes newly erased areas or - #scrolled text to be written using color index zero, the screen background. This is VT - #and DECterm compatible. Text background causes erased areas or scrolled text to be - #written using the current text background color. This is PC console compatible and is - #the factory default. - - #see also: https://unix.stackexchange.com/questions/251726/clear-to-end-of-line-uses-the-wrong-background-color-in-screen - } - } - } - } - = { - set num [tcl::string::range $codenorm 5 end-1] ;#param between = and h|l - puts stderr "overtype::renderline CSI=...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - default { - #e.g CSI 4 h - set num [tcl::string::range $codenorm 4 end-1] ;#param before h|l - switch -exact -- $num { - 3 { - puts stderr "CRM MODE $code_end" - #CRM - Show control character mode - # 'No control functions are executed except LF,FF and VT which are represented in the CRM FONT before a CRLF(new line) is executed' - # - #use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2 - #https://vt100.net/docs/vt510-rm/CRM.html - #NOTE - vt100 CRM always does auto-wrap at right margin. - #disabling auto-wrap in set-up or by sequence is disabled. - #We should default to turning off auto-wrap when crm_mode enabled.. but - #displaying truncated (on rhs) crm can still be very useful - and we have optimisation in overflow to avoid excess renderline calls (per grapheme) - #we therefore could reasonably put in an exception to allow auto_wrap to be disabled after crm_mode is engaged, - #although this would be potentially an annoying difference to some.. REVIEW - if {$code_end eq "h"} { - set crm_mode 1 - set autowrap_mode 1 - if {$opt_width ne "\uFFEF"} { - set overflow_idx $opt_width - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - } else { - set crm_mode 0 - } - } - 4 { - #IRM - Insert/Replace Mode - if {$code_end eq "h"} { - #CSI 4 h - set insert_mode 1 - } else { - #CSI 4 l - #replace mode - set insert_mode 0 - } - } - default { - puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - } - } - } - | { - switch -- [tcl::string::index $codenorm end-1] { - {$} { - #CSI ... $ | DECSCPP set columns per page- (recommended in vt510 docs as preferable to DECCOLM) - #real terminals generally only supported 80/132 - #some other virtuals support any where from 2 to 65,536? - #we will allow arbitrary widths >= 2 .. to some as yet undetermined limit. - #CSI $ | - #empty or 0 param is 80 for compatibility - other numbers > 2 accepted - set page_width -1 ;#flag as unset - if {$param eq ""} { - set page_width 80 - } elseif {[string is integer -strict $param] && $param >=2 0} { - set page_width [expr {$param}] ;#we should allow leading zeros in the number - but lets normalize using expr - } else { - puts stderr "overtype::renderline unacceptable DECSPP value '$param'" - } - - if {$page_width > 2} { - puts stderr "overtype::renderline DECSCPP - not implemented - but selected width '$page_width' looks ok" - #if cursor already beyond new page_width - will move to right colum - otherwise no cursor movement - - } - - } - default { - puts stderr "overtype::renderline unrecognised CSI code ending in pipe (|) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - } - default { - puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - } - 7ESC { - # - #re_other_single {\x1b(D|M|E)$} - #also vt52 Y.. - #also PM \x1b^...(ST) - switch -- [tcl::string::index $codenorm 4] { - c { - #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! - puts stderr "renderline reset" - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction reset - break - } - D { - #\x84 - #index (IND) - #vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up" - puts stderr "renderline ESC D not fully implemented" - incr cursor_row - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction down - #retain cursor_column - break - } - E { - #\x85 - #review - is behaviour different to lf? - #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL - #leave implementation until logic for is set in stone... still under review - #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. - # - #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" - puts stderr "overtype::renderline ESC E unimplemented" - - } - H { - #\x88 - #Tab Set - puts stderr "overtype::renderline ESC H tab set unimplemented" - } - M { - #\x8D - #Reverse Index (RI) - #vt102-docs: "Moves cursor up one line in same column. If cursor is at top margin, screen performs a scroll-down" - puts stderr "overtype::renderline ESC M not fully implemented" - - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move up - incr cursor_row -1 - if {$cursor_row < 1} { - set cursor_row 1 - } - #ensure rest of *overlay* is emitted to remainder - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction up ;#need instruction for scroll-down? - #retain cursor_column - break - } - N { - #\x8e - affects next character only - puts stderr "overtype::renderline single shift select G2 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - O { - #\x8f - affects next character only - puts stderr "overtype::renderline single shift select G3 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - P { - #\x90 - #DCS - shouldn't get here - handled in 7DCS branch - #similarly \] OSC (\x9d) and \\ (\x9c) ST - } - V { - #\x96 - - } - W { - #\x97 - } - X { - #\x98 - #SOS - if {[string index $code end] eq "\007"} { - set sos_content [string range $code 2 end-1] ;#ST is \007 - } else { - set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ - } - #return in some useful form to the caller - #TODO! - lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] - puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - ^ { - #puts stderr "renderline PM" - #Privacy Message. - if {[string index $code end] eq "\007"} { - set pm_content [string range $code 2 end-1] ;#ST is \007 - } else { - set pm_content [string range $code 2 end-2] ;#ST is \x1b\\ - } - #We don't want to render it - but we need to make it available to the application - #see the textblock library in punk, for the exception we make here for single backspace. - #It is unlikely to be encountered as a useful PM - so we hack to pass it through as a fix - #for spacing issues on old terminals which miscalculate the single-width 'Symbols for Legacy Computing' - if {$pm_content eq "\b"} { - #puts stderr "renderline PM sole backspace special handling for \U1FB00 - \U1FBFF" - #esc^\b\007 or esc^\besc\\ - #HACKY pass-through - targeting terminals that both mis-space legacy symbols *and* don't support PMs - #The result is repair of the extra space. If the terminal is a modern one and does support PM - the \b should be hidden anyway. - #If the terminal has the space problem AND does support PMs - then this just won't fix it. - #The fix relies on the symbol-supplier to cooperate by appending esc^\b\esc\\ to the problematic symbols. - - #priv::render_addchar $idx $code [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #idx has been incremented after last grapheme added - priv::render_append_to_char [expr {$idx -1}] $code - } - #lappend to a dict element in the result for application-specific processing - lappend pm_list $pm_content - } - _ { - #APC Application Program Command - #just warn for now.. - puts stderr "overtype::renderline ESC_ APC command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - default { - puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" - } - } - - } - 7DCS - 8DCS { - puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - #ST (string terminator) \x9c or \x1b\\ - if {[tcl::string::index $codenorm end] eq "\x9c"} { - set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c - } else { - set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ - } - - } - 7OSC - 8OSC { - # OSCs are terminated with ST of either \007 or \x1b\\ - we allow either whether code was 7 or 8 bit - if {[tcl::string::index $codenorm end] eq "\007"} { - set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is \007 - } else { - set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ - } - set first_colon [tcl::string::first {;} $code_content] - if {$first_colon == -1} { - #there probably should always be a colon - but we'll try to make sense of it without - set osc_code $code_content ;#e.g \x1b\]104\007 vs \x1b\]104\;\007 - } else { - set osc_code [tcl::string::range $code_content 0 $first_colon-1] - } - switch -exact -- $osc_code { - 2 { - set newtitle [tcl::string::range $code_content 2 end] - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction [list set_window_title $newtitle] - break - } - 4 { - #OSC 4 - set colour palette - #can take multiple params - #e.g \x1b\]4\;1\;red\;2\;green\x1b\\ - set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon - set cmap [dict create] - foreach {cnum spec} [split $params {;}] { - if {$cnum >= 0 and $cnum <= 255} { - #todo - parse spec from names like 'red' to RGB - #todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc) - #also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ? - dict set cmap $cnum $spec - } else { - #todo - log - puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - - - } - 10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 { - #OSC 10 through 17 - so called 'dynamic colours' - #can take multiple params - each successive parameter changes the next colour in the list - #- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more - #10 change text foreground colour - #11 change text background colour - #12 change text cursor colour - #13 change mouse foreground colour - #14 change mouse background colour - #15 change tektronix foreground colour - #16 change tektronix background colour - #17 change highlight colour - set params [tcl::string::range $code_content 2 end] - - puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - - - } - 18 { - #why is this not considered one of the dynamic colours above? - #https://www.xfree86.org/current/ctlseqs.html - #tektronix cursor color - puts stderr "overtype::renderline OSC 18 - set tektronix cursor color unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - 99 { - #kitty desktop notifications - #https://sw.kovidgoyal.net/kitty/desktop-notifications/ - # 99 ; metadata ; payload - puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - 104 { - #reset colour palette - #we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt - puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction [list reset_colour_palette] - break - } - 1337 { - #iterm2 graphics and file transfer - puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" - } - 5113 { - puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" - } - default { - puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - default { - } - } - - - } - default { - #don't need to handle sgr or gx0 types - #we have our sgr gx0 codes already in stacks for each overlay grapheme - } - } - } - - #-------- - if {$opt_expand_right == 0} { - #need to truncate to the width of the original undertext - #review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? - #set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars - } - if {$overflow_idx == -1} { - #overflow was initially unlimited and hasn't been overridden - } else { - - } - #-------- - - - #coalesce and replay codestacks for outcols grapheme list - set outstring "" ;#output prior to overflow - set overflow_right "" ;#remainder after overflow point reached - set i 0 - set cstack [list] - set prevstack [list] - set prev_g0 [list] - #note overflow_idx may already have been set lower if we had a row move above due to \v or ANSI moves - set in_overflow 0 ;#used to stop char-width scanning once in overflow - if {$overflow_idx == 0} { - #how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW - set in_overflow 1 - } - set trailing_nulls 0 - foreach ch [lreverse $outcols] { - if {$ch eq "\u0000"} { - incr trailing_nulls - } else { - break - } - } - if {$trailing_nulls} { - set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}] - } else { - set first_tail_null_posn -1 - } - - #puts stderr "first_tail_null_posn: $first_tail_null_posn" - #puts stderr "colview: [ansistring VIEW $outcols]" - - foreach ch $outcols { - #puts "---- [ansistring VIEW $ch]" - - set gxleader "" - if {$i < [llength $understacks_gx]} { - #set g0 [tcl::dict::get $understacks_gx $i] - set g0 [lindex $understacks_gx $i] - if {$g0 ne $prev_g0} { - if {$g0 eq [list "gx0_on"]} { - set gxleader "\x1b(0" - } else { - set gxleader "\x1b(B" - } - } - set prev_g0 $g0 - } else { - set prev_g0 [list] - } - - set sgrleader "" - if {$i < [llength $understacks]} { - #set cstack [tcl::dict::get $understacks $i] - set cstack [lindex $understacks $i] - if {$cstack ne $prevstack} { - if {[llength $prevstack] && ![llength $cstack]} { - #This reset is important e.g testfile fruit.ans - we get overhang on rhs without it. But why is cstack empty? - append sgrleader \033\[m - } else { - append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] - } - } - set prevstack $cstack - } else { - set prevstack [list] - } - - - - if {$in_overflow} { - if {$i == $overflow_idx} { - set 0 [lindex $understacks_gx $i] - set gxleader "" - if {$g0 eq [list "gx0_on"]} { - set gxleader "\x1b(0" - } elseif {$g0 eq [list "gx0_off"]} { - set gxleader "\x1b(B" - } - append overflow_right $gxleader - set cstack [lindex $understacks $i] - set sgrleader "" - #whether cstack is same or differs from previous char's stack - we must have an output at the start of the overflow_right - #if {[llength $prevstack] && ![llength $cstack]} { - # append sgrleader \033\[m - #} - append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] - append overflow_right $sgrleader - append overflow_right $ch - } else { - append overflow_right $gxleader - append overflow_right $sgrleader - append overflow_right $ch - } - } else { - if {$overflow_idx != -1 && $i+1 == $overflow_idx} { - #one before overflow - #will be in overflow in next iteration - set in_overflow 1 - if {[grapheme_width_cached $ch]> 1} { - #we overflowed with second-half of a double-width char - replace first-half with user-supplied exposition char (should be 1 wide) - set ch $opt_exposed1 - } - } - append outstring $gxleader - append outstring $sgrleader - if {$ch eq "\u0000"} { - if {$cp437_glyphs} { - #map all nulls including at tail to space - append outstring " " - } else { - if {$trailing_nulls && $i < $first_tail_null_posn} { - append outstring " " ;#map inner nulls to space - } else { - append outstring \u0000 - } - } - } else { - append outstring $ch - } - } - incr i - } - #flower.ans good test for null handling - reverse line building - #review - presence of overflow_right doesn't indicate line's trailing nulls should remain. - #The cells could have been erased? - #if {!$cp437_glyphs} { - # #if {![ansistring length $overflow_right]} { - # # set outstring [tcl::string::trimright $outstring "\u0000"] - # #} - # set outstring [tcl::string::trimright $outstring "\u0000"] - # set outstring [tcl::string::map {\u0000 " "} $outstring] - #} - - - #REVIEW - #set overflow_right [tcl::string::trimright $overflow_right "\u0000"] - #set overflow_right [tcl::string::map {\u0000 " "} $overflow_right] - - set replay_codes "" - if {[llength $understacks] > 0} { - if {$overflow_idx == -1} { - #set tail_idx [tcl::dict::size $understacks] - set tail_idx [llength $understacks] - } else { - set tail_idx [llength $undercols] - } - if {$tail_idx-1 < [llength $understacks]} { - #set replay_codes [join [lindex $understacks $tail_idx-1] ""] ;#tail replay codes - set replay_codes [punk::ansi::codetype::sgr_merge_list {*}[lindex $understacks $tail_idx-1]] ;#tail replay codes - } - if {$tail_idx-1 < [llength $understacks_gx]} { - set gx0 [lindex $understacks_gx $tail_idx-1] - if {$gx0 eq [list "gx0_on"]} { - #if it was on, turn gx0 off at the point we stop processing overlay - append outstring "\x1b(B" - } - } - } - if {[string length $overflow_right]} { - #puts stderr "remainder:$overflow_right" - } - #pdict $understacks - - if {[punk::ansi::ta::detect_sgr $outstring]} { - append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column - - #close off any open gx? - #probably should - and overflow_right reopen? - } - - if {$opt_returnextra} { - #replay_codes is the codestack at the boundary - used for ellipsis colouring to match elided text - review - #replay_codes_underlay is the set of codes in effect at the very end of the original underlay - - #review - #replay_codes_overlay is the set of codes in effect at the very end of the original overlay (even if not all overlay was applied) - #todo - replay_codes for gx0 mode - - #overflow_idx may change during ansi & character processing - if {$overflow_idx == -1} { - set overflow_right_column "" - } else { - set overflow_right_column [expr {$overflow_idx+1}] - } - set result [tcl::dict::create\ - result $outstring\ - visualwidth [punk::ansi::printing_length $outstring]\ - instruction $instruction\ - stringlen [string length $outstring]\ - overflow_right_column $overflow_right_column\ - overflow_right $overflow_right\ - unapplied $unapplied\ - unapplied_list $unapplied_list\ - insert_mode $insert_mode\ - autowrap_mode $autowrap_mode\ - crm_mode $crm_mode\ - reverse_mode $reverse_mode\ - insert_lines_above $insert_lines_above\ - insert_lines_below $insert_lines_below\ - cursor_saved_position $cursor_saved_position\ - cursor_saved_attributes $cursor_saved_attributes\ - cursor_column $cursor_column\ - cursor_row $cursor_row\ - expand_right $opt_expand_right\ - replay_codes $replay_codes\ - replay_codes_underlay $replay_codes_underlay\ - replay_codes_overlay $replay_codes_overlay\ - pm_list $pm_list\ - ] - if {$opt_returnextra == 1} { - #puts stderr "renderline: $result" - return $result - } else { - #human/debug - map special chars to visual glyphs - set viewop VIEW - switch -- $opt_returnextra { - 2 { - #codes and character data - set viewop VIEWCODES ;#ansi colorisation of codes - green for SGR, blue/blue reverse for cursor_save/cursor_restore, cyan for movements, orange for others - } - 3 { - set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. - } - } - tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] - tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]] - tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]] - tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]] - tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] - tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] - tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] - tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] - return $result - } - } else { - #puts stderr "renderline returning: result $outstring instruction $instruction unapplied $unapplied overflow_right $overflow_right" - return $outstring - } - #return [join $out ""] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace overtype ---}] -} - -tcl::namespace::eval overtype::piper { - proc overcentre {args} { - if {[llength $args] < 2} { - error {usage: ?-bias left|right? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} - } - lassign [lrange $args end-1 end] over under - set argsflags [lrange $args 0 end-2] - tailcall overtype::centre {*}$argsflags $under $over - } - proc overleft {args} { - if {[llength $args] < 2} { - error {usage: ?-startcolumn ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} - } - lassign [lrange $args end-1 end] over under - set argsflags [lrange $args 0 end-2] - tailcall overtype::left {*}$argsflags $under $over - } -} - - -# -- --- --- --- --- --- --- --- --- --- --- -proc overtype::transparentline {args} { - foreach {under over} [lrange $args end-1 end] break - set argsflags [lrange $args 0 end-2] - set defaults [tcl::dict::create\ - -transparent 1\ - -exposed 1 " "\ - -exposed 2 " "\ - ] - set newargs [tcl::dict::merge $defaults $argsflags] - tailcall overtype::renderline {*}$newargs $under $over -} -#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway. -# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense. -#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines. -# -tcl::namespace::eval overtype::piper { - proc renderline {args} { - if {[llength $args] < 2} { - error {usage: ?-start ? ?-transparent [0|1|]? ?-overflow [1|0]? overtext pipelinedata} - } - foreach {over under} [lrange $args end-1 end] break - set argsflags [lrange $args 0 end-2] - tailcall overtype::renderline {*}$argsflags $under $over - } -} -interp alias "" piper_renderline "" overtype::piper::renderline - -#intended primarily for single grapheme - but will work for multiple -#WARNING: query CAN contain ansi or newlines - but if cache was not already set manually,the answer will be incorrect! -#We deliberately allow this for PM/SOS attached within a column -#(a cache of ansifreestring_width calls - as these are quite regex heavy) -proc overtype::grapheme_width_cached {ch} { - variable grapheme_widths - if {[tcl::dict::exists $grapheme_widths $ch]} { - return [tcl::dict::get $grapheme_widths $ch] - } - set width [punk::char::ansifreestring_width $ch] - tcl::dict::set grapheme_widths $ch $width - return $width -} - - - -proc overtype::test_renderline {} { - set t \uFF5E ;#2-wide tilde - set u \uFF3F ;#2-wide underscore - set missing \uFFFD - return [list $t $u A${t}B] -} - -#maintenance warning -#same as textblock::size - but we don't want that circular dependency -#block width and height can be tricky. e.g \v handled differently on different terminal emulators and can affect both -proc overtype::blocksize {textblock} { - if {$textblock eq ""} { - return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings - } - if {[tcl::string::first \t $textblock] >= 0} { - if {[info exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - #ansistrip on entire block in one go rather than line by line - result should be the same - review - make tests - if {[punk::ansi::ta::detect $textblock]} { - set textblock [punk::ansi::ansistrip $textblock] - } - if {[tcl::string::last \n $textblock] >= 0} { - set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map {\n {}} $textblock]]}] ;#faster than splitting into single-char list - set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } else { - set num_le 0 - set width [punk::char::ansifreestring_width $textblock] - } - #our concept of block-height is likely to be different to other line-counting mechanisms - set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le - - return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize ]] width height -} - -tcl::namespace::eval overtype::priv { - variable cache_is_sgr [tcl::dict::create] - - #we are likely to be asking the same question of the same ansi codes repeatedly - #caching the answer saves some regex expense - possibly a few uS to lookup vs under 1uS - #todo - test if still worthwhile after a large cache is built up. (limit cache size?) - proc is_sgr {code} { - variable cache_is_sgr - if {[tcl::dict::exists $cache_is_sgr $code]} { - return [tcl::dict::get $cache_is_sgr $code] - } - set answer [punk::ansi::codetype::is_sgr $code] - tcl::dict::set cache_is_sgr $code $answer - return $answer - } - # better named render_to_unapplied? - proc render_unapplied {overlay_grapheme_control_list gci} { - upvar idx_over idx_over - upvar unapplied unapplied - upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split - upvar overstacks overstacks - upvar overstacks_gx overstacks_gx - upvar overlay_grapheme_control_stacks og_stacks - - #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] - set unapplied "" - set unapplied_list [list] - #append unapplied [join [lindex $overstacks $idx_over] ""] - #append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] - set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] - if {$sgr_merged ne ""} { - lappend unapplied_list $sgr_merged - } - switch -- [lindex $overstacks_gx $idx_over] { - "gx0_on" { - lappend unapplied_list "\x1b(0" - } - "gx0_off" { - lappend unapplied_list "\x1b(B" - } - } - - foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { - lassign $gc type item - #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - } - set unapplied [join $unapplied_list ""] - } - - #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack - proc render_this_unapplied {overlay_grapheme_control_list gci} { - upvar idx_over idx_over - upvar unapplied unapplied - upvar unapplied_list unapplied_list - upvar overstacks overstacks - upvar overstacks_gx overstacks_gx - upvar overlay_grapheme_control_stacks og_stacks - - #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] - set unapplied "" - set unapplied_list [list] - - set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] - if {$sgr_merged ne ""} { - lappend unapplied_list $sgr_merged - } - switch -- [lindex $overstacks_gx $idx_over] { - "gx0_on" { - lappend unapplied_list "\x1b(0" - } - "gx0_off" { - lappend unapplied_list "\x1b(B" - } - } - - foreach gc [lrange $overlay_grapheme_control_list $gci end] { - lassign $gc type item - #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - } - set unapplied [join $unapplied_list ""] - } - proc render_delchar {i} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - set nxt [llength $o] - if {$i < $nxt} { - set o [lreplace $o $i $i] - set ustacks [lreplace $ustacks $i $i] - set gxstacks [lreplace $gxstacks $i $i] - } elseif {$i == 0 || $i == $nxt} { - #nothing to do - } else { - puts stderr "render_delchar - attempt to delchar at index $i >= number of outcols $nxt - shouldn't happen" - } - } - proc render_erasechar {i count} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - upvar replay_codes_overlay replay - #ECH clears character attributes from erased character positions - #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller of render_erasechar should do that mapping and only supply 1 or greater. - if {![tcl::string::is integer -strict $count] || $count < 1} { - error "render_erasechar count must be integer >= 1" - } - set start $i - set end [expr {$i + $count -1}] - #we restrict ECH to current line - as some terminals do - review - is that the only way it's implemented? - if {$i > [llength $o]-1} { - return - } - if {$end > [llength $o]-1} { - set end [expr {[llength $o]-1}] - } - set num [expr {$end - $start + 1}] - set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space? - #DECECM ??? - set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list $replay]]] - set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] ;# ??? review - return - } - proc render_setchar {i c } { - upvar outcols o - lset o $i $c - } - - #Initial usecase is for old-terminal hack to add PM-wrapped \b - #review - can be used for other multibyte sequences that occupy one column? - #combiners? diacritics? - proc render_append_to_char {i c} { - upvar outcols o - if {$i > [llength $o]-1} { - error "render_append_to_char cannot append [ansistring VIEW -lf 1 -nul 1 $c] to existing char at index $i while $i >= llength outcols [llength $o]" - } - set existing [lindex $o $i] - if {$existing eq "\0"} { - lset o $i $c - } else { - lset o $i $existing$c - } - } - #is actually addgrapheme? - proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - - # -- --- --- - #this is somewhat of a hack.. probably not really the equivalent of proper reverse video? review - #we should ideally be able to reverse the video of a sequence that already includes SGR reverse/noreverse attributes - upvar reverse_mode do_reverse - #if {$do_reverse} { - # lappend sgrstack [a+ reverse] - #} else { - # lappend sgrstack [a+ noreverse] - #} - - #JMN3 - if {$do_reverse} { - #note we can't just look for \x1b\[7m or \x1b\[27m - # it may be a more complex sequence like \x1b\[0\;\;7\;31m etc - - set existing_reverse_state 0 - set codeinfo [punk::ansi::codetype::sgr_merge $sgrstack -info 1] - set codestate_reverse [dict get $codeinfo codestate reverse] - switch -- $codestate_reverse { - 7 { - set existing_reverse_state 1 - } - 27 { - set existing_reverse_state 0 - } - "" { - } - } - if {$existing_reverse_state == 0} { - set rflip [a+ reverse] - } else { - #reverse of reverse - set rflip [a+ noreverse] - } - #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) - set sgrstack [list [dict get $codeinfo mergeresult] $rflip] - #set sgrstack [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] - } - - # -- --- --- - - set nxt [llength $o] - if {!$insert_mode} { - if {$i < $nxt} { - #These lists must always be in sync - lset o $i $c - } else { - lappend o $c - } - if {$i < [llength $ustacks]} { - lset ustacks $i $sgrstack - lset gxstacks $i $gx0stack - } else { - lappend ustacks $sgrstack - lappend gxstacks $gx0stack - } - } else { - #insert of single-width vs double-width when underlying is double-width? - if {$i < $nxt} { - set o [linsert $o $i $c] - } else { - lappend o $c - } - if {$i < [llength $ustacks]} { - set ustacks [linsert $ustacks $i $sgrstack] - set gxstacks [linsert $gxstacks $i $gx0stack] - } else { - lappend ustacks $sgrstack - lappend gxstacks $gx0stack - } - } - } - -} - - - -# -- --- --- --- --- --- --- --- --- --- --- -tcl::namespace::eval overtype { - interp alias {} ::overtype::center {} ::overtype::centre -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide overtype [tcl::namespace::eval overtype { - variable version - set version 1.6.6 -}] -return - -#*** !doctools -#[manpage_end] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/pattern-1.2.4.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/pattern-1.2.4.tm deleted file mode 100644 index d6a9c932..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/pattern-1.2.4.tm +++ /dev/null @@ -1,1285 +0,0 @@ -#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. -#------------------------------------------------------------ -#::p::-1 ::p::internals::>metaface -#::p::0 ::p::ifaces::>null -#::p::1 ::>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 pattern [namespace eval pattern {variable version; set version 1.2.4}] - - -namespace eval pattern::util { - - # Generally better to use 'package require $minver-' - # - this only gives us a different error - proc package_require_min {pkg minver} { - if {[package vsatisfies [lindex [set available [lsort -increasing [package versions $pkg]]] end] $minver-]} { - package require $pkg - } else { - error "Package pattern requires package $pkg of at least version $minver. Available: $available" - } - } -} - -package require patterncmd 1.2.4- -package require metaface 1.2.4- ;#utility/system diagnostic commands (may be used by metaface lib etc) - - - -#package require cmdline -package require overtype - -#package require md5 ;#will be loaded if/when needed -#package require md4 -#package require uuid - - - - - -namespace eval pattern { - variable initialised 0 - - - if 0 { - if {![catch {package require twapi_base} ]} { - #twapi is a windows only package - #MUCH faster to load just twapi_base than full 'package require twapi' IFF using the modular twapi distribution with multiple separately loadable dlls. - # If available - windows seems to provide a fast uuid generator.. - #*IF* tcllibc is missing, then as at 2008-05 twapi::new_uuid is significantly faster than uuid::uuid generate ( e.g 19 usec vs 76thousand usec! on 2.4GHZ machine) - # (2018 update - 15-30usec vs ~200usec on core i9 @ ~2.6GHZ (time for a single call e.g time {pattern::new_uuid})) - interp alias {} ::pattern::new_uuid {} ::twapi::new_uuid -localok - } else { - #performance on freebsd seems not great, but adequate. (e.g 500usec on dualcore 1.6GHZ) - # (e.g 200usec 2018 corei9) - #(with or without tcllibc?) - #very first call is extremely slow though - 3.5seconds on 2018 corei9 - package require uuid - interp alias {} ::pattern::new_uuid {} ::uuid::uuid generate - } - #variable fastobj 0 ;#precalculated invocant ID in method body (instead of call time ) - removed for now - see pattern 1.2.1 (a premature optimisation which was hampering refactoring & advancement) - } - - -} - - - - - - -namespace eval p { - #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 internals {} - - - #!?? - #namespace export ?? - variable coroutine_instance 0 -} - -#------------------------------------------------------------------------------------- -#review - what are these for? -#note - this function is deliberately not namespaced -# - it begins with the letters 'proc' (as do the created aliases) - to aid in editor's auto indexing/mapping features -proc process_pattern_aliases {object args} { - set o [namespace tail $object] - interp alias {} process_patternmethod_$o {} [$object .. PatternMethod .] - interp alias {} process_method_$o {} [$object .. Method .] - interp alias {} process_constructor_$o {} [$object .. Constructor .] -} -#------------------------------------------------------------------------------------- - - - - -#!store all interface objects here? -namespace eval ::p::ifaces {} - - - -#K combinator - see http://wiki.tcl.tk/1923 -#proc ::p::K {x y} {set x} -#- not used - use inline K if desired i.e set x [lreplace $x[set x{}] $a $b blah] - - - - - - - - -proc ::p::internals::(VIOLATE) {_ID_ violation_script} { - #set out [::p::fixed_var_statements @IMPLICITDECLS@\n$violation_script] - set processed [dict create {*}[::p::predator::expand_var_statements $violation_script]] - - if {![dict get $processed explicitvars]} { - #no explicit var statements - we need the implicit ones - set self [set ::p::${_ID_}::(self)] - set IFID [lindex [set $self] 1 0 end] - #upvar ::p::${IFID}:: self_IFINFO - - - set varDecls {} - set vlist [array get ::p::${IFID}:: v,name,*] - set _k ""; set v "" - if {[llength $vlist]} { - append varDecls "upvar #0 " - foreach {_k v} $vlist { - append varDecls "::p::\${_ID_}::$v $v " - } - append varDecls "\n" - } - - #set violation_script [string map [::list @IMPLICITDECLS@ $varDecls] $out] - set violation_script $varDecls\n[dict get $processed body] - - #tidy up - unset processed varDecls self IFID _k v - } else { - set violation_script [dict get $processed body] - } - unset processed - - - - - #!todo - review (& document) exactly what context this script runs in and what vars/procs are/should be visible. - eval "unset violation_script;$violation_script" -} - - -proc ::p::internals::DestroyObjectsBelowNamespace {ns} { - #puts "\n##################\n#################### destroyObjectsBelowNamespace $ns\n" - - set nsparts [split [string trim [string map {:: :} $ns] :] :] - if { ! ( ([llength $nsparts] == 3) & ([lindex $nsparts 0] == "p") & ([lindex $nsparts end] eq "_ref") )} { - #ns not of form ::p::?::_ref - - foreach obj [info commands ${ns}::>*] { - #catch {::p::meta::Destroy $obj} - #puts ">>found object $obj below ns $ns - destroying $obj" - $obj .. Destroy - } - } - - #set traces [trace info variable ${ns}::-->PATTERN_ANCHOR] - #foreach tinfo $traces { - # trace remove variable ${ns}::-->PATTERN_ANCHOR {*}$tinfo - #} - #unset -nocomplain ${ns}::-->PATTERN_ANCHOR - - foreach sub [namespace children $ns] { - ::p::internals::DestroyObjectsBelowNamespace $sub - } -} - - - - -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# -################################################# - - - - - - - - - -proc ::p::get_new_object_id {} { - tailcall incr ::p::ID - #tailcall ::pattern::new_uuid -} - -#create a new minimal object - with no interfaces or patterns. - -#proc ::p::internals::new_object [list cmd {wrapped ""} [list OID [expr {-2}]]] {} -proc ::p::internals::new_object {cmd {wrapped ""} {OID "-2"}} { - - #puts "-->new_object cmd:$cmd wrapped:$wrapped OID:$OID" - - if {$OID eq "-2"} { - set OID [::p::get_new_object_id] - #set OID [incr ::p::ID] ;#!todo - use uuids? (too slow?) (use uuids as configurable option?, pre-allocate a list of uuids?) - #set OID [pattern::new_uuid] - } - #if $wrapped provided it is assumed to be an existing namespace. - #if {[string length $wrapped]} { - # #??? - #} - - #sanity check - alias must not exist for this OID - if {[llength [interp alias {} ::p::$OID]]} { - error "Object alias '::p::$OID' already exists - cannot create new object with this id" - } - - #system 'varspaces' - - - #until we have a version of Tcl that doesn't have 'creative writing' scope issues - - # - we should either explicity specify the whole namespace when setting variables or make sure we use the 'variable' keyword. - # (see http://wiki.tcl.tk/1030 'Dangers of creative writing') - #set o_open 1 - every object is initially also an open interface (?) - #NOTE! comments within namespace eval slow it down. - namespace eval ::p::$OID { - #namespace ensemble create - namespace eval _ref {} - namespace eval _meta {} - namespace eval _iface { - variable o_usedby; - variable o_open 1; - array set o_usedby [list]; - variable o_varspace "" ; - variable o_varspaces [list]; - variable o_methods [dict create]; - variable o_properties [dict create]; - variable o_variables; - variable o_propertyunset_handlers; - set o_propertyunset_handlers [dict create] - } - } - - #set alias ::p::$OID - - #objectid alis default_method object_command wrapped_namespace - set INVOCANTDATA [list $OID ::p::$OID "" $cmd $wrapped] - - #MAP is a dict - set MAP [list invocantdata $INVOCANTDATA interfaces {level0 {} level0_default "" level1 {} level1_default ""} patterndata {patterndefaultmethod ""}] - - - - #NOTE 'interp alias' will prepend :: if chosen srccmd already exists as an alias token - #we've already checked that ::p::$OID doesn't pre-exist - # - so we know the return value of the [interp alias {} $alias {} ...] will be $alias - #interp alias {} ::p::$OID {} ::p::internals::predator $MAP - - - # _ID_ structure - set invocants_dict [dict create this [list $INVOCANTDATA] ] - #puts stdout "New _ID_structure: $interfaces_dict" - set _ID_ [dict create i $invocants_dict context ""] - - - interp alias {} ::p::$OID {} ::p::internals::predator $_ID_ - #rename the command into place - thus the alias & the command name no longer match! - rename ::p::$OID $cmd - - set ::p::${OID}::_meta::map $MAP - - # called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something - interp alias {} ::p::${OID}:: {} ::p::internals::no_default_method $_ID_ - - #set p2 [string map {> ?} $cmd] - #interp alias {} $p2 {} ::p::internals::alternative_predator $_ID_ - - - #trace add command $cmd delete "$cmd .. Destroy ;#" - #puts "@@@ trace add command $cmd rename [list $cmd .. Rename]" - - trace add command $cmd rename [list $cmd .. Rename] ;#will receive $oldname $newname "rename" - #trace add command $cmd rename [$cmd .. Rename .] ;#EXTREMELY slow. (but why?) - - #puts "@@@ trace added for $cmd -> '[trace info command $cmd]'" - - - #uplevel #0 "trace add command $cmd delete \"puts deleting$cmd ;#\"" - #trace add command $cmd delete "puts deleting$cmd ;#" - #puts stdout "trace add command $cmd delete \"puts deleting$cmd ;#\"" - - - #puts "--> new_object returning map $MAP" - return $MAP -} - - - - -#>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 -# - - - - - - -#set ::p::internals::predator to a particular predatorversion (from a patternpredatorX package) -proc ::pattern::predatorversion {{ver ""}} { - variable active_predatorversion - set allowed_predatorversions {1 2} - set default_predatorversion [lindex $allowed_predatorversions end] ;#default to last in list of allowed_predatorversions - - if {![info exists active_predatorversion]} { - set first_time_set 1 - } else { - set first_time_set 0 - } - - if {$ver eq ""} { - #get version - if {$first_time_set} { - set active_predatorversions $default_predatorversion - } - return $active_predatorversion - } else { - #set version - if {$ver ni $allowed_predatorversions} { - error "Invalid attempt to set predatorversion - unknown value: $ver, try one of: $allowed_predatorversions" - } - - if {!$first_time_set} { - if {$active_predatorversion eq $ver} { - #puts stderr "Active predator version is already '$ver'" - #ok - nothing to do - return $active_predatorversion - } else { - package require patternpredator$ver 1.2.4- - if {![llength [info commands ::p::predator$ver]]} { - error "Unable to set predatorversion - command ::p::predator$ver not found" - } - rename ::p::internals::predator ::p::predator$active_predatorversion - } - } - package require patternpredator$ver 1.2.4- - if {![llength [info commands ::p::predator$ver]]} { - error "Unable to set predatorversion - command ::p::predator$ver not found" - } - - rename ::p::predator$ver ::p::internals::predator - set active_predatorversion $ver - - return $active_predatorversion - } -} -::pattern::predatorversion 2 - - - - - - - - - - - - -# >pattern has object ID 1 -# meta interface has object ID 0 -proc ::pattern::init 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 - } - } - - #this seems out of date. - # - where is PatternPropertyRead? - # - Object is obsolete - # - Coinjoin, Combine don't seem to exist - array set ::p::metaMethods { - Clone object - Conjoin object - Combine object - Create object - Destroy simple - Info simple - Object simple - PatternProperty simple - PatternPropertyWrite simple - PatternPropertyUnset simple - Property simple - PropertyWrite simple - PatternMethod simple - Method simple - PatternVariable simple - Variable simple - Digest simple - PatternUnknown simple - Unknown simple - } - array set ::p::metaProperties { - Properties object - Methods object - PatternProperties object - PatternMethods object - } - - - - - - #create metaface - IID = -1 - also OID = -1 - # all objects implement this special interface - accessed via the .. operator. - - - - - - set ::p::ID 4 ;#0,1,2,3 reserved for null interface,>pattern, >ifinfo & ::p::>interface - - - #OID = 0 - ::p::internals::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 - ############################### - ::p::internals::new_object ::>pattern "" 1 - - #set ::>pattern [list [list 1 ::>pattern item] [list [list 0] [list 0]]] - - - array set ::p::1::_iface::o_usedby [list] ;#'usedby' array - - 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 - #lset SELFMAP 1 0 $IFID - #lset SELFMAP 2 0 $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 alias} - return $alias - } - ::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 {pattern::util::package_require_min patternlib 1.2.4} - #uplevel #0 {package require patternlib} - return 1 -} - - - -proc ::p::merge_interface {old new} { - #puts stderr " ** ** ** merge_interface $old $new" - set ns_old ::p::$old - set ns_new ::p::$new - - upvar #0 ::p::${new}:: IFACE - upvar #0 ::p::${old}:: IFACEX - - if {![catch {set c_arglist $IFACEX(c,args)}]} { - #constructor - #for now.. just add newer constructor regardless of any existing one - #set IFACE(c,args) $IFACEX(c,args) - - #if {![info exists IFACE(c,args)]} { - # #target interface didn't have a constructor - # - #} else { - # # - #} - } - - - set methods [::list] - foreach nm [array names IFACEX m-1,name,*] { - lappend methods [lindex [split $nm ,] end] ;#use the method key-name not the value! (may have been overridden) - } - - #puts " *** merge interface $old -> $new ****merging-in methods: $methods " - - foreach method $methods { - if {![info exists IFACE(m-1,name,$method)]} { - #target interface doesn't yet have this method - - set THISNAME $method - - if {![string length [info command ${ns_new}::$method]]} { - - if {![set ::p::${old}::_iface::o_open]} { - #interp alias {} ${ns_new}::$method {} ${ns_old}::$method - #namespace eval $ns_new "namespace export [namespace tail $method]" - } else { - #wait to compile - } - - } else { - error "merge interface - command collision " - } - #set i 2 ??? - set i 1 - - } else { - #!todo - handle how? - #error "command $cmd already exists in interface $new" - - - set i [incr IFACE(m-1,chain,$method)] - - set THISNAME ___system___override_${method}_$i - - #move metadata using subindices for delegated methods - set IFACE(m-$i,name,$method) $IFACE(m-1,name,$method) - set IFACE(m-$i,iface,$method) $IFACE(m-1,iface,$method) - set IFACE(mp-$i,$method) $IFACE(mp-1,$method) - - set IFACE(m-$i,body,$method) $IFACE(m-1,body,$method) - set IFACE(m-$i,args,$method) $IFACE(m-1,args,$method) - - - #set next [::p::next_script $IFID0 $method] - if {![string length [info command ${ns_new}::$THISNAME]]} { - if {![set ::p::${old}::_iface::o_open]} { - interp alias {} ${ns_new}::$THISNAME {} ${ns_old}::$method - namespace eval $ns_new "namespace export $method" - } else { - #wait for compile - } - } else { - error "merge_interface - command collision " - } - - } - - array set IFACE [::list \ - m-1,chain,$method $i \ - m-1,body,$method $IFACEX(m-1,body,$method) \ - m-1,args,$method $IFACEX(m-1,args,$method) \ - m-1,name,$method $THISNAME \ - m-1,iface,$method $old \ - ] - - } - - - - - - #array set ${ns_new}:: [array get ${ns_old}::] - - - #!todo - review - #copy everything else across.. - - foreach {nm v} [array get IFACEX] { - #puts "-.- $nm" - if {([string first "m-1," $nm] != 0) && ($nm ne "usedby")} { - set IFACE($nm) $v - } - } - - #!todo -write a test - set ::p::${new}::_iface::o_open 1 - - #!todo - is this done also when iface compiled? - #namespace eval ::p::$new {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 - - return -} - - - - -#detect attempt to treat a reference to a method as a property -proc ::p::internals::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 ::p::internals::commandrefMisuse_TraceHandler $OID $field $args] - - #!todo - don't use vtraced! - trace add variable $vtraced {read write unset array} [concat ::p::internals::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 -#} - - - - -################################################################################################################################################ -################################################################################################################################################ -################################################################################################################################################ - -#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 ::p::internals::no_default_method {_ID_ args} { - puts stderr "p::internals::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? or use PatternDefaultMethod)" -} - -#force 1 will extend an interface even if shared. (??? why is this necessary here?) -#if IID empty string - create the interface. -proc ::p::internals::expand_interface {IID {force 0}} { - #puts stdout ">>> expand_interface $IID [info level -1]<<<" - if {![string length $IID]} { - #return [::p::internals::new_interface] ;#new interface is by default open for extending (o_open = 1) - set iid [expr {$::p::ID + 1}] - ::p::>interface .. Create ::p::ifaces::>$iid - return $iid - } else { - if {[set ::p::${IID}::_iface::o_open]} { - #interface open for extending - shared or not! - return $IID - } - - if {[array size ::p::${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 [::p::internals::new_interface] - set IID [expr {$::p::ID + 1}] - ::p::>interface .. Create ::p::ifaces::>$IID - - ::p::internals::linkcopy_interface $prev_IID $IID - #assert: prev_usedby contains at least one other element. - } - - #whether copied or not - mark as open for extending. - set ::p::${IID}::_iface::o_open 1 - return $IID - } -} - -#params: old - old (shared) interface ID -# new - new interface ID -proc ::p::internals::linkcopy_interface {old new} { - #puts stderr " ** ** ** linkcopy_interface $old $new" - set ns_old ::p::${old}::_iface - set ns_new ::p::${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 ::p::${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 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm deleted file mode 100644 index ca061a7c..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patterncmd-1.2.4.tm +++ /dev/null @@ -1,645 +0,0 @@ -package provide patterncmd [namespace eval patterncmd { - variable version - - set version 1.2.4 -}] - - -namespace eval pattern { - variable idCounter 1 ;#used by pattern::uniqueKey - - namespace eval cmd { - namespace eval util { - package require overtype - variable colwidths_lib [dict create] - variable colwidths_lib_default 15 - - dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] - dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] - dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] - dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] - - proc colhead {type args} { - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - set line "" - foreach colname [dict keys $colwidths] { - append line "[col $type $colname [string totitle $colname] {*}$args]" - } - return $line - } - proc colbreak {type} { - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - set line "" - foreach colname [dict keys $colwidths] { - append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" - } - return $line - } - proc col {type col val args} { - # args -head bool -tail bool ? - #---------------------------------------------------------------------------- - set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] - dict set default -backchar "" - dict set default -headchar "" - dict set default -tailchar "" - dict set default -headoverridechar "" - dict set default -tailoverridechar "" - dict set default -justify "left" - if {([llength $args] % 2) != 0} { - error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " - } - foreach {k v} $args { - if {$k ni $known_opts} { - error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" - } - } - set opts [dict merge $default $args] - set backchar [dict get $opts -backchar] - set headchar [dict get $opts -headchar] - set tailchar [dict get $opts -tailchar] - set headoverridechar [dict get $opts -headoverridechar] - set tailoverridechar [dict get $opts -tailoverridechar] - set justify [dict get $opts -justify] - #---------------------------------------------------------------------------- - - - - upvar #0 ::pattern::cmd::util::colwidths_$type colwidths - #calculate headwidths - set headwidth 0 - set tailwidth 0 - foreach {key def} $colwidths { - set thisheadlen [string length [dict get $def head]] - if {$thisheadlen > $headwidth} { - set headwidth $thisheadlen - } - set thistaillen [string length [dict get $def tail]] - if {$thistaillen > $tailwidth} { - set tailwidth $thistaillen - } - } - - - set spec [dict get $colwidths $col] - if {[string length $backchar]} { - set ch $backchar - } else { - set ch [dict get $spec ch] - } - set num [dict get $spec num] - set headchar [dict get $spec head] - set tailchar [dict get $spec tail] - - if {[string length $headchar]} { - set headchar $headchar - } - if {[string length $tailchar]} { - set tailchar $tailchar - } - #overrides only apply if the head/tail has a length - if {[string length $headchar]} { - if {[string length $headoverridechar]} { - set headchar $headoverridechar - } - } - if {[string length $tailchar]} { - if {[string length $tailoverridechar]} { - set tailchar $tailoverridechar - } - } - set head [string repeat $headchar $headwidth] - set tail [string repeat $tailchar $tailwidth] - - set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] - if {$justify eq "left"} { - set left_done [overtype::left $base "$head$val"] - return [overtype::right $left_done "$tail"] - } elseif {$justify in {centre center}} { - set mid_done [overtype::centre $base $val] - set left_mid_done [overtype::left $mid_done $head] - return [overtype::right $left_mid_done $tail] - } else { - set right_done [overtype::right $base "$val$tail"] - return [overtype::left $right_done $head] - } - - } - - } - } - -} - -#package require pattern - -proc ::pattern::libs {} { - set libs [list \ - pattern {-type core -note "alternative:pattern2"}\ - pattern2 {-type core -note "alternative:pattern"}\ - patterncmd {-type core}\ - metaface {-type core}\ - patternpredator2 {-type core}\ - patterndispatcher {-type core}\ - patternlib {-type core}\ - patterncipher {-type optional -note optional}\ - ] - - - - package require overtype - set result "" - - append result "[cmd::util::colbreak lib]\n" - append result "[cmd::util::colhead lib -justify centre]\n" - append result "[cmd::util::colbreak lib]\n" - foreach libname [dict keys $libs] { - set libinfo [dict get $libs $libname] - - append result [cmd::util::col lib library $libname] - if {[catch [list package present $libname] ver]} { - append result [cmd::util::col lib version "N/A"] - } else { - append result [cmd::util::col lib version $ver] - } - append result [cmd::util::col lib type [dict get $libinfo -type]] - - if {[dict exists $libinfo -note]} { - set note [dict get $libinfo -note] - } else { - set note "" - } - append result [cmd::util::col lib note $note] - append result "\n" - } - append result "[cmd::util::colbreak lib]\n" - return $result -} - -proc ::pattern::record {recname fields} { - if {[uplevel 1 [list namespace which $recname]] ne ""} { - error "(pattern::record) Can't create command '$recname': A command of that name already exists" - } - - set index -1 - set accessor [list ::apply { - {index rec args} - { - if {[llength $args] == 0} { - return [lindex $rec $index] - } - if {[llength $args] == 1} { - return [lreplace $rec $index $index [lindex $args 0]] - } - error "Invalid number of arguments." - } - - }] - - set map {} - foreach field $fields { - dict set map $field [linsert $accessor end [incr index]] - } - uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] -} -proc ::pattern::record2 {recname fields} { - if {[uplevel 1 [list namespace which $recname]] ne ""} { - error "(pattern::record) Can't create command '$recname': A command of that name already exists" - } - - set index -1 - set accessor [list ::apply] - - set template { - {rec args} - { - if {[llength $args] == 0} { - return [lindex $rec %idx%] - } - if {[llength $args] == 1} { - return [lreplace $rec %idx% %idx% [lindex $args 0]] - } - error "Invalid number of arguments." - } - } - - set map {} - foreach field $fields { - set body [string map [list %idx% [incr index]] $template] - dict set map $field [list ::apply $body] - } - uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] -} - -proc ::argstest {args} { - package require cmdline - -} - -proc ::pattern::objects {} { - set result [::list] - - foreach ns [namespace children ::pp] { - #lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] - set ch [namespace tail $ns] - if {[string range $ch 0 2] eq "Obj"} { - set OID [string range $ch 3 end] ;#OID need not be digits (!?) - lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] - } - } - - - - - return $result -} - - - -proc ::pattern::name {num} { - #!todo - fix - #set ::p::${num}::(self) - - lassign [interp alias {} ::p::$num] _predator info - if {![string length $_predator$info]} { - error "No object found for num:$num (no interp alias for ::p::$num)" - } - set invocants [dict get $info i] - set invocants_with_role_this [dict get $invocants this] - set invocant_this [lindex $invocants_with_role_this 0] - - - #lassign $invocant_this id info - #set map [dict get $info map] - #set fields [lindex $map 0] - lassign $invocant_this _id _ns _defaultmethod name _etc - return $name -} - - -proc ::pattern::with {cmd script} { - foreach c [info commands ::p::-1::*] { - interp alias {} [namespace tail $c] {} $c $cmd - } - interp alias {} . {} $cmd . - interp alias {} .. {} $cmd .. - - return [uplevel 1 $script] -} - - - - - -#system diagnostics etc - -proc ::pattern::varspace_list {IID} { - namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables - - set varspaces [list] - dict for {vname vdef} $o_variables { - set vs [dict get $vdef varspace] - if {$vs ni $varspaces} { - lappend varspaces $vs - } - } - if {$o_varspace ni $varspaces} { - lappend varspaces $o_varspace - } - return $varspaces -} - -proc ::pattern::check_interfaces {} { - foreach ns [namespace children ::p] { - set IID [namespace tail $ns] - if {[string is digit $IID]} { - foreach ref [array names ${ns}::_iface::o_usedby] { - set OID [string range $ref 1 end] - if {![namespace exists ::p::${OID}::_iface]} { - puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" - } else { - puts -nonewline stdout . - } - - - #if {![info exists ::p::${OID}::(self)]} { - # puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" - #} - } - } - } - puts -nonewline stdout "\r\n" -} - - -#from: http://wiki.tcl.tk/8766 (Introspection on aliases) -#usedby: metaface-1.1.6+ -#required because aliases can be renamed. -#A renamed alias will still return it's target with 'interp alias {} oldname' -# - so given newname - we require which_alias to return the same info. - proc ::pattern::which_alias {cmd} { - uplevel 1 [list ::trace add execution $cmd enterstep ::error] - catch {uplevel 1 $cmd} res - uplevel 1 [list ::trace remove execution $cmd enterstep ::error] - #puts stdout "which_alias $cmd returning '$res'" - return $res - } -# [info args] like proc following an alias recursivly until it reaches -# the proc it originates from or cannot determine it. -# accounts for default parameters set by interp alias -# - - - -proc ::pattern::aliasargs {cmd} { - set orig $cmd - - set defaultargs [list] - - # loop until error or return occurs - while {1} { - # is it a proc already? - if {[string equal [info procs $cmd] $cmd]} { - set result [info args $cmd] - # strip off the interp set default args - return [lrange $result [llength $defaultargs] end] - } - # is it a built in or extension command we can get no args for? - if {![string equal [info commands $cmd] $cmd]} { - error "\"$orig\" isn't a procedure" - } - - # catch bogus cmd names - if {[lsearch [interp aliases {}] $cmd]==-1} { - if {[catch {::pattern::which_alias $cmd} alias]} { - error "\"$orig\" isn't a procedure or alias or command" - } - #set cmd [lindex $alias 0] - if {[llength $alias]>1} { - set cmd [lindex $alias 0] - set defaultargs [concat [lrange $alias 1 end] $defaultargs] - } else { - set cmd $alias - } - } else { - - if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { - # check if it is aliased in from another interpreter - if {[catch {interp target {} $cmd} msg]} { - error "Cannot resolve \"$orig\", alias leads to another interpreter." - } - if {$msg != {} } { - error "Not recursing into slave interpreter \"$msg\".\ - \"$orig\" could not be resolved." - } - # check if defaults are set for the alias - if {[llength $cmdargs]>1} { - set cmd [lindex $cmdargs 0] - set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] - } else { - set cmd $cmdargs - } - } - } - } - } -proc ::pattern::aliasbody {cmd} { - set orig $cmd - - set defaultargs [list] - - # loop until error or return occurs - while {1} { - # is it a proc already? - if {[string equal [info procs $cmd] $cmd]} { - set result [info body $cmd] - # strip off the interp set default args - return $result - #return [lrange $result [llength $defaultargs] end] - } - # is it a built in or extension command we can get no args for? - if {![string equal [info commands $cmd] $cmd]} { - error "\"$orig\" isn't a procedure" - } - - # catch bogus cmd names - if {[lsearch [interp aliases {}] $cmd]==-1} { - if {[catch {::pattern::which_alias $cmd} alias]} { - error "\"$orig\" isn't a procedure or alias or command" - } - #set cmd [lindex $alias 0] - if {[llength $alias]>1} { - set cmd [lindex $alias 0] - set defaultargs [concat [lrange $alias 1 end] $defaultargs] - } else { - set cmd $alias - } - } else { - - if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { - # check if it is aliased in from another interpreter - if {[catch {interp target {} $cmd} msg]} { - error "Cannot resolve \"$orig\", alias leads to another interpreter." - } - if {$msg != {} } { - error "Not recursing into slave interpreter \"$msg\".\ - \"$orig\" could not be resolved." - } - # check if defaults are set for the alias - if {[llength $cmdargs]>1} { - set cmd [lindex $cmdargs 0] - set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] - } else { - set cmd $cmdargs - } - } - } - } - } - - - - - -proc ::pattern::uniqueKey2 {} { - #!todo - something else?? - return [clock seconds]-[incr ::pattern::idCounter] -} - -#used by patternlib package -proc ::pattern::uniqueKey {} { - return [incr ::pattern::idCounter] - #uuid with tcllibc is about 30us compared with 2us - # for large datasets, e.g about 100K inserts this would be pretty noticable! - #!todo - uuid pool with background thread to repopulate when idle? - #return [uuid::uuid generate] -} - - - -#------------------------------------------------------------------------------------------------------------------------- - -proc ::pattern::test1 {} { - set msg "OK" - - puts stderr "next line should say:'--- saystuff:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. PatternMethod saystuff args { - puts stderr "--- saystuff: $args" - } - ::>thing .. Create ::>jjj - - ::>jjj . saystuff $msg - ::>jjj .. Destroy - ::>thing .. Destroy -} - -proc ::pattern::test2 {} { - set msg "OK" - - puts stderr "next line should say:'--- property 'stuff' value:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. PatternProperty stuff $msg - - ::>thing .. Create ::>jjj - - puts stderr "--- property 'stuff' value:[::>jjj . stuff]" - ::>jjj .. Destroy - ::>thing .. Destroy -} - -proc ::pattern::test3 {} { - set msg "OK" - - puts stderr "next line should say:'--- property 'stuff' value:$msg" - ::>pattern .. Create ::>thing - - ::>thing .. Property stuff $msg - - puts stderr "--- property 'stuff' value:[::>thing . stuff]" - ::>thing .. Destroy -} - -#--------------------------------- -#unknown/obsolete - - - - - - - - -#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} -if {0} { - proc ::p::internals::new_interface {{usedbylist {}}} { - set OID [incr ::p::ID] - ::p::internals::new_object ::p::ifaces::>$OID "" $OID - puts "obsolete >> new_interface created object $OID" - foreach usedby $usedbylist { - set ::p::${OID}::_iface::o_usedby(i$usedby) 1 - } - set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) - #NOTE - o_varspace is only the default varspace for when new methods/properties are added. - # it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. - - set ::p::${OID}::_iface::o_constructor [list] - set ::p::${OID}::_iface::o_variables [list] - set ::p::${OID}::_iface::o_properties [dict create] - set ::p::${OID}::_iface::o_methods [dict create] - array set ::p::${OID}::_iface::o_definition [list] - set ::p::${OID}::_iface::o_open 1 ;#open for extending - return $OID - } - - - #temporary way to get OID - assumes single 'this' invocant - #!todo - make generic. - proc ::pattern::get_oid {_ID_} { - #puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" - return [lindex [dict get $_ID_ i this] 0 0] - - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - #set role_members [dict get $invocants this] - ##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. - #set this_invocant [lindex [dict get $_ID_ i this] 0] ; - #lassign $this_invocant OID this_info - # - #return $OID - } - - #compile the uncompiled level1 interface - #assert: no more than one uncompiled interface present at level1 - proc ::p::meta::PatternCompile {self} { - ???? - - upvar #0 $self SELFMAP - set ID [lindex $SELFMAP 0 0] - - set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces - - set iid -1 - foreach i $patterns { - if {[set ::p::${i}::_iface::o_open]} { - set iid $i ;#found it - break - } - } - - if {$iid > -1} { - #!todo - - ::p::compile_interface $iid - set ::p::${iid}::_iface::o_open 0 - } else { - #no uncompiled interface present at level 1. Do nothing. - return - } - } - - - proc ::p::meta::Def {self} { - error ::p::meta::Def - - upvar #0 $self SELFMAP - set self_ID [lindex $SELFMAP 0 0] - set IFID [lindex $SELFMAP 1 0 end] - - set maxc1 0 - set maxc2 0 - - set arrName ::p::${IFID}:: - - upvar #0 $arrName state - - array set methods {} - - foreach nm [array names state] { - if {[regexp {^m-1,name,(.+)} $nm _match mname]} { - set methods($mname) [set state($nm)] - - if {[string length $mname] > $maxc1} { - set maxc1 [string length $mname] - } - if {[string length [set state($nm)]] > $maxc2} { - set maxc2 [string length [set state($nm)]] - } - } - } - set bg1 [string repeat " " [expr {$maxc1 + 2}]] - set bg2 [string repeat " " [expr {$maxc2 + 2}]] - - - set r {} - foreach nm [lsort -dictionary [array names methods]] { - set arglist $state(m-1,args,$nm) - append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" - } - return $r - } - - - -} \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternlib-1.2.6.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternlib-1.2.6.tm deleted file mode 100644 index bd4b3e59..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternlib-1.2.6.tm +++ /dev/null @@ -1,2590 +0,0 @@ -#JMN 2004 -#public domain - - -package provide patternlib [namespace eval patternlib { - - variable version - set version 1.2.6 -}] - - - -#Change History -#------------------------------------------------------------------------------- -#2022-05 -# added . search and . itemKeys methods to >collection to enable lookups by value -#2021-09 -# Add >keyvalprotector - an object to overload various collection methods such as 'remove' to stop deletion of specific items. -# -#2006-05 -# deprecate 'del' in favour of 'remove' - 'del' still there but delegated to 'remove'. todo - emit deprecation warnings. -# -#2005-04 -# remove 'name' method - incorporate indexed retrieval into 'names' method -# !todo? - adjust key/keys methods for consistency? -# -#2004-10 -# initial key aliases support -# fix negative index support on some methods e.g remove -#2004-08 -# separated >collection predicate methods out onto separate 'mixin' object >predicatedCollection -# added $posn $result variables to predicate methods, changed varnames from $k $v to $key $value -# -#2004-06-05 -# added 'sort' method to sort on values. -# fixed 'keySort' method to accept multiple sort options -# added predicate methods 'all' 'allKeys' 'collectAll' -#2004-06-01 -# '>collection . names' method now accepts optional 'glob' parameter to filter result -#2004-05-19 -#fix '>collection . clear' method so consecutive calls don't raise an error -#------------------------------------------------------------------------------- - -namespace eval ::patternlib::util { - proc package_require_min {pkg minver} { - if {[package vsatisfies [lindex [set available [lsort -increasing [package versions $pkg]]] end] $minver-]} { - package require $pkg - } else { - error "Package pattern requires package $pkg of at least version $minver. Available: $available" - } - } - - #bloom filter experiment https://wiki.tcl-lang.org/page/A+Simple+Bloom+Filter - # k-hashes - # m-bits - # n-elements - # optimal value of k: (m/n)ln(2) - #proc bloom_optimalNumHashes {capacity_n bitsize_m} { - # expr { round((double($bitsize_m) / $capacity_n) * log(2))} - #} - #proc bloom_optimalNumBits {capacity fpp} { - # expr {entier(-$capacity * log($fpp) / (log(2) * log(2)))} - #} - -} -::patternlib::util::package_require_min pattern 1.2.4 -#package require pattern -::pattern::init ;# initialises (if not already) - - -namespace eval ::patternlib {namespace export {[a-z]*} - namespace export {[>]*} - - variable keyCounter 0 ;#form part of unique keys for collections when items added without any key specified - proc uniqueKey {} { - return [incr ::patternlib::keyCounter] - } - -#!todo - multidimensional collection -# - o_list as nested list -# - o_array with compound keys(?) how will we unambiguously delimit dimensions in a concatenated key? -# - perhaps a key is always a list length n where n is the number of dimensions? -# - therefore we'll need an extra level of nesting for the current base case n=1 -# -# - how about a nested dict for each key-structure (o_list & o_array) ? - -#COLLECTION -# -#!todo? - consider putting the actual array & list vars in the objects namespace, and using the instancevars to hold their names -# - consider array-style access using traced var named same as collection. -# would this defeat the purpose ? if it was faster, would users always use array syntax in preference.. in which case they may as well just use arrays..? -#!todo - add boolean property to force unique values as well as keys - - -#::pattern::create >collection - - - - -::>pattern .. Create >collection -set COL >collection -#process_pattern_aliases [namespace origin >collection] -#process_pattern_aliases ::patternlib::>collection -$COL .. Property version 1.0 -$COL .. PatternDefaultMethod item - -set PV [$COL .. PatternVariable .] - -$PV o_data -#$PV o_array -#$PV o_list -$PV o_alias -$PV this - -#for invert method -$PV o_dupes 0 - - -$COL .. PatternProperty bgEnum - - -#PV o_ns - -$PV m_i_filteredCollection - -#set ID [lindex [set >collection] 0 0] ;#context ID -#set IID [lindex [set >collection] 1 0] ;#level 1 base-interface ID - -$COL .. Constructor {args} { - var o_data m_i_filteredCollection o_count o_bgEnum - - var this - set this @this@ - - set m_i_filteredCollection 0 - if {![llength $args]} { - set o_data [dict create] - #array set o_array [list] - #set o_list [list] - set o_count 0 - } elseif {[llength $args] == 1} { - set o_data [dict create] - set pairs [lindex $args 0] - if {[llength $pairs] % 2} { - error "patternllib::>collection - if an argument given to constructor, it must have an even number of elements. Bad args: $args" - } - set keys_seen [list] - foreach key [dict keys $pairs] { - if {[string is integer -strict $key] } { - error ">collection key must be non-integer. Bad key: $key. No items added." - } - if {$key in $keys_seen} { - error "key '$key' already exists in this collection. No items added." - } - lappend keys_seen $key - } - unset keys_seen - #rely on dict ordering guarantees (post 8.5? preserves order?) - set o_data [dict merge $o_data[set o_data {}] $pairs] - set o_count [dict size $o_data] - } else { - error "patternlib::>collection constructor did not understand arguments supplied. Try a dict as a single argument." - } - array set o_alias [list] - - array set o_bgEnum [list] - @next@ -} -#comment block snipped from collection Constructor - #--------------------------------------------- - #set o_selfID [lindex [set $o_this] 0] ;#object id always available in methods as $_ID_ anyway - # - #### OBSOLETE - left as example of an approach - #make count property traceable (e.g so property ref can be bound to Tk widgets) - #!todo - manually update o_count in relevant methods faster?? - # should avoid trace calls for addList methods, shuffle etc - # - #set handler ::p::${_ID_}::___count_TraceHandler - #proc $handler {_ID_ vname vidx op} { - # #foreach {vname vidx op} [lrange $args end-2 end] {break} - # #! we shouldn't trust this vname - it may be that we are being accessed via upvar so it is a different name - # - # #this is only a 'write' handler - # set ::p::[lindex ${_ID_} 0 0]::o_count [llength [set ::p::[lindex ${_ID_} 0 0]::o_list]] - # return - #} - #trace add variable o_list {write} [list $handler $_ID_] - #### - # - # - #puts "--->collection constructor id: $_ID_" - - - - -set PM [$COL .. PatternMethod .] - - -#!review - why do we need the count method as well as the property? -#if needed - document why. -# read traces on count property can be bypassed by method call... shouldn't we avoid that? -#2018 - in theory write traces on the . count property are very useful from an application-writer's perpective. -# -$COL .. PatternMethod count {} { - #we don't require any instance vars to be upvar'ed - argless [var] stops them automatically being added. - #we directly refer to the ::O:: var if only accessing a few times rather than upvar'ing. - var o_data - dict size $o_data -} - -$COL .. PatternProperty count -$COL .. PatternPropertyWrite count {_val} { - var - error "count property is read-only" -} - -$COL .. PatternPropertyUnset count {} { - var -} ;#cannot raise error's in unset trace handlers - simply fail to unset silently - -$COL .. PatternMethod isEmpty {} { - #var o_list - #return [expr {[llength $o_list] == 0}] - var o_data - expr {[dict size $o_data] == 0} -} - -$COL .. PatternProperty inverted 0 - - - -###### -# item -###### -#defaults to fifo when no idx supplied (same as 'pair' method). !review? is lifo more logical/intuitive/useful? -# i.e [>obj . item] returns the 1st element in the list -#[>obj . item -1] returns the last element (equiv to "end" keyword used by Tcl list commands) -#[>obj . item -2] returns 2nd last element (equiv to "end-1") - - -$COL .. PatternMethod item {{idx 0}} { - #with pattern::0::$OID access.. was measured faster than item2 : approx 110us vs 140us for 26element collection accessed via string (time {>col $key} 10000) - # (still at least 20 times slower than a plain array... at <5us) - var o_data o_alias - - #!todo - review 'string is digit' vs 'string is integer' ?? - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - set keys [dict keys $o_data] - if {[catch {dict get $o_data [lindex $keys $idx]} result]} { - var this - error "no such index : '$idx' in collection: $this" - } else { - return $result - } - } else { - if {[catch {dict get $o_data $idx} result]} { - if {[catch {set o_alias($idx)} nextIdx ]} { - var this - error "no such index: '$idx' in collection: $this" - } else { - #try again - #return $o_array($nextIdx) - #tailcall? - #item $_ID_ $nextIdx - #puts stdout "\n\n\n !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! about to call tailcall item $_ID_ $nextIdx \n\n\n" - tailcall item $_ID_ $nextIdx - } - } else { - return $result - } - } -} - - - -if {0} { -#leave this here for comparison. -$COL .. PatternMethod item2 {{idx 0}} { - var o_array o_list o_alias this - - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - - if {[catch {set o_array([lindex $o_list $idx])} result]} { - error "no such index : '$idx' in collection: $this" - } else { - return $result - } - } else { - if {[catch {set o_array($idx)} result]} { - - if {[catch {set o_alias($idx)} nextIdx ]} { - error "no such index: '$idx' in collection: $this" - } else { - #try again - #return $o_array($nextIdx) - item $_ID_ $nextIdx - } - } else { - return $result - } - } - -} -} - -#simple no-frills access for speed.. (timed at 43us vs 63us for item (depending on dispatch method!)) -$COL .. PatternMethod itemNamed {idx} { - var o_data - dict get $o_data $idx -} -$COL .. PatternMethod in {idx} { - var o_data - dict get $o_data $idx -} - -$COL .. PatternMethod itemAt {idx} { - var o_data - dict get $o_data [lindex [dict keys $o_data] $idx] -} - -$COL .. PatternMethod replace {idx val} { - var o_data o_alias this - - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - - if {[catch {dict set o_data [lindex [dict keys $o_data] $idx] $val}]} { - error "no such index: '$idx' in collection: $this" - } else { - return $val - } - } else { - if {[catch {dict set o_data $idx $val}]} { - if {[catch {set o_alias($idx)} nextIdx ]} { - error "no such index: '$idx' in collection: $this" - } else { - #try again - tailcall replace $_ID_ $nextIdx $val - } - - } else { - return $val - } - } -} - -#if the supplied index is an alias, return the underlying key; else return the index supplied. -$COL .. PatternMethod realKey {idx} { - var o_alias - - if {[catch {set o_alias($idx)} key]} { - return $idx - } else { - return $key - } -} - -#note alias feature is possibly ill-considered. -#if we delete an item - should we delete corresponding alias? If not - we then would need to allow adding under an alias only if the corresponding key is missing. -$COL .. PatternMethod alias {newAlias existingKeyOrAlias} { - var o_alias - - #set existingKey [realKey $_ID_ $existingKeyOrAlias] - #alias to the supplied KeyOrAlias - not the underlying key - - if {[string is integer -strict $newAlias]} { - error "collection key alias cannot be integer" - } - - if {[string length $existingKeyOrAlias]} { - set o_alias($newAlias) $existingKeyOrAlias - } else { - unset o_alias($newAlias) - } -} -$COL .. PatternMethod aliases {{key ""}} { - var o_alias - - if {[string length $key]} { - set result [list] - #lsearch -stride? - foreach {n v} [array get o_alias] { - if {$v eq $key} { - lappend result $n $v - } - } - - return $result - } else { - return [array get o_alias] - } -} - -#'pop' & 'unshift' methods !todo - optimize so lsearch not called when numerical idx/posn already supplied - -#default to removing item from the end, otherwise from supplied index (position or key) -#!todo - accept alias indices -#!todo - review.. should any corresponding alias be destroyed when the corresponding item is popped (or removed in any way?) -#!todo - review.. for performance.. shouldn't pop NOT accept an index? -#if we need to pop from other than the end.. this could be a separate function. Do other langs use pop with an index?? -$COL .. PatternMethod pop {{idx ""}} { - var o_data o_count - - if {$idx eq ""} { - set key [lindex [dict keys $o_data] end] - } else { - if {[string is integer -strict $idx]} { - set key [lindex [dict keys $o_data] $idx] - } else { - set key $idx - } - } - set posn [lsearch -exact [dict keys $o_data] $key] - - if {($posn >= 0) && ($posn < [dict size $o_data])} { - set result [dict get $o_data $key] - dict unset o_data $key - set o_count [dict size $o_data] - return $result - } else { - error "no such index: '$idx'" - } -} -$COL .. PatternMethod poppair {} { - var o_data o_count - set key [lindex [dict keys $o_data] end] - set val [dict get $o_data $key] - dict unset o_data $key - set o_count [dict size $o_data] - return [list $key $val] -} - - - -#!todo - add 'push' method... (basically specialized versions of 'add') -#push - add at end (effectively an alias for add) -#shift - add at start ???bad name? this is completely at odds with for example the common Perl shift function, which returns and removes the first element of an array. -#add - add at end - -#ordered -$COL .. PatternMethod items {} { - var o_data - - dict values $o_data -} - - - - -#### -#pair -#### -#fifo-style accesss when no idx supplied (likewise with 'add' method) -$COL .. PatternMethod pair {{idx 0}} { - var o_data - - if {[string is integer -strict $idx]} { - set key [lindex [dict keys $o_data] $idx] - } else { - set key $idx - } - - if {[catch {dict get $o_data $key} val]} { - error "no such index: '$idx'" - } else { - return [list $key $val] - } -} -$COL .. PatternMethod pairs {} { - var o_data - set o_data -} - -$COL .. PatternMethod get {} { - var o_data - set o_data -} -#todo - fix >pattern so that methods don't collide with builtins -#may require change to use oo - or copy 'my' mechanism to call own methods -$COL .. PatternMethod Info {} { - var o_data - return [dict info $o_data] -} -#2006-05-21.. args to add really should be in key, value order? -# - this the natural order in array-like lists -# - however.. key should be optional. - -$COL .. PatternMethod add {val args} { - #(using args instead of {key ""} enables use of empty string as a key ) - - var o_data o_alias o_count this - - if {![llength $args]} { - set key "_[::patternlib::uniqueKey]_" - } else { - #!todo - could we handle multiple val,key pairs without impacting performance of the common case? - if {[llength $args] > 1} { - error "add method expected 'val' and optional 'key' - got: $val $args" - - } - - set key [lindex $args 0] - if {[string is integer -strict $key]} { - error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" - } - } - - if {[dict exists $o_data $key]} { - #error "key $key already exists in collection [set ::p::[lindex ${_ID_} 0 0]::this]" - error "key '$key' already exists in collection $this" - } - if {[info exists o_alias($key)]} { - if {[dict exists $o_data $o_alias($key)]} { - #only disallow adding via the alias if there is an existing o_data element for the key pointed to by the alias - error "key '$key' already exists as an alias for $o_alias($key) in collection $this" - } - } - - dict set o_data $key $val - - - set posn $o_count - incr o_count - - return $posn -} - - -#should the 'stack' methods such as shift,push,pop,peek actually be on a separate interface? -#what then of methods like 'count' which apply equally well to collections and stacks? - -#Alias for 'add' - is there a way to alias this to add implementation with zero overhead?? -$COL .. PatternMethod push {val args} { - #(using args instead of {key ""} enables use of empty string as a key ) - - var o_data o_alias o_count this - - if {![llength $args]} { - set key "_[::patternlib::uniqueKey]_" - } else { - #!todo - could we handle multiple val,key pairs without impacting performance of the common case? - if {[llength $args] > 1} { - error "add method expected 'val' and optional 'key' - got: $val $args" - - } - - set key [lindex $args 0] - if {[string is integer -strict $key]} { - error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" - } - } - - if {[dict exists $o_data $key]} { - #error "key $key already exists in collection [set ::p::[lindex ${_ID_} 0 0]::this]" - error "key '$key' already exists in collection $this" - } - if {[info exists o_alias($key)]} { - if {[dict exists $o_data $o_alias($key)]} { - #only disallow adding via the alias if there is an existing o_data element for the key pointed to by the alias - error "key '$key' already exists as an alias for $o_alias($key) in collection $this" - } - } - - dict set o_data $key $val - - - set posn $o_count - incr o_count - - return $posn -} - - -#shift/unshift - roughly analogous to those found in Perl & PHP -#unshift adds 1 or more values to the beginning of the collection. -$COL .. PatternMethod unshift {values {keys ""}} { - var o_data o_count - - if {![llength $keys]} { - for {set i 0} {$i < [llength $values]} {incr i} { - lappend keys "_[::patternlib::uniqueKey]_" - } - } else { - #check keys before we insert any of them. - foreach newkey $keys { - if {[string is integer -strict $newkey]} { - error "cannot accept key '$newkey', >collection keys must be non-numeric. Other structures such as >hashMap allow user specified integer keys" - } - } - } - if {[llength $values] != [llength $keys]} { - error "unshift requires same number of keys as values. (or no keys for auto-generated keys) Received [llength $values] values, [llength $keys] keys" - } - - #separate loop through keys because we want to fail the whole operation if any are invalid. - - set existing_keys [dict keys $o_data] - foreach newkey $keys { - if {$newkey in $exisint_keys} { - #puts stderr "==============> key $key already exists in this collection" - error "key '$newkey' already exists in this collection" - } - } - - - #ok - looks like entire set can be inserted. - set newpairs [list] - foreach val $values key $keys { - lappend newpairs $key $val - } - set o_data [concat $newpairs $o_data[set o_data {}]] - set o_count [dict size $o_data] - - return [expr {$o_count - 1}] -} - -#default to removing item from the beginning, otherwise from supplied index (position or key) -#!todo - accept alias indices -$COL .. PatternMethod shift {{idx ""}} { - var o_data o_count - - if {$idx eq ""} { - set key [lindex [dict keys $o_data] 0] - } else { - if {[string is integer -strict $idx]} { - set key [lindex [dict keys $o_data] $idx] - } else { - set key $idx - } - } - set posn [lsearch -exact [dict keys $o_data] $key] - - if {($posn >= 0) && (($posn/2) < [dict size $o_data])} { - set result [dict get $o_data $key] - dict unset o_data $key - set o_count [dict size $o_data] - return $result - } else { - error "no such index: '$idx'" - } -} - - -$COL .. PatternMethod peek {} { - var o_data - - #set o_array([lindex $o_list end]) - - #dict get $o_data [lindex [dict keys $o_data] end] - lindex $o_data end -} - -$COL .. PatternMethod peekKey {} { - var o_data - #lindex $o_list end - lindex $o_data end-1 -} - - -$COL .. PatternMethod insert {val args} { - var o_data o_count - - set idx 0 - set key "" - - if {[llength $args] <= 2} { - #standard arg (ordered) style: - #>obj . insert $value $position $key - - lassign $args idx key - } else { - #allow for literate programming style: - #e.g - # >obj . insert $value at $listPosition as $key - - if {[catch {array set iargs $args}]} { - error "insert did not understand argument list. -usage: ->obj . insert \$val \$position \$key ->obj . insert \$val at \$position as \$key" - } - if {[info exists iargs(at)]} { - set idx $iargs(at) - } - if {[info exists iargs(as)]} { - set key $iargs(as) - } - } - - if {![string length $key]} { - set key "_[::patternlib::uniqueKey]_" - } - - if {[string is integer -strict $key]} { - error ">collection key must be non-numeric. Other structures such as >hashMap allow user specified integer keys" - } - - - if {[dict exists $o_data $key]} { - #puts stderr "==============> key $key already exists in this collection" - error "key '$key' already exists in this collection" - } - - if {$idx eq "end"} { - #lappend o_list $key - #standard dict set will add it to the end anyway - dict set o_data $key $val - - } else { - #set o_list [linsert $o_list $idx $key] - - #treat dict as list - set o_data [linsert $o_data[set o_data {}] [expr {$idx*2}] $key $val] - } - - - #set o_array($key) $val - - - set o_count [dict size $o_data] - - return [expr {$o_count - 1}] -} - -#!todo - deprecate and give it a better name! addDict addPairs ? -$COL .. PatternMethod addArray {list} { - var - puts stderr "patternlib::>collection WARNING: addArray deprecated - call addPairs with same argument instead" - tailcall addPairs $_ID_ $list -} -$COL .. PatternMethod addPairs {list} { - var o_data o_alias o_count - if {[llength $list] % 2} { - error "must supply an even number of elements" - } - - set aliaslist [array names o_alias] - #set keylist [dict keys $o_data] - foreach newkey [dict keys $list] { - if {[string is integer -strict $newkey] } { - error ">collection key must be non-integer. Bad key: $newkey. No items added." - } - - #if {$newkey in $keylist} {} - #for small to medium collections - testing for newkey in $keylist is probably faster, - # but we optimise here for potentially large existing collections, where presumably a dict exists lookup will be more efficient. - if {[dict exists $o_data $newkey]} { - error "key '$newkey' already exists in this collection. No items added." - } - #The assumption is that there are in general relatively few aliases - so a list test is appropriate - if {$newkey in $aliaslist} { - if {[dict exists $o_data $o_alias($newkey)]} { - error "key '$newkey' already exists as an alias for $o_alias($newkey) in collection. No items added " - } - } - #! check if $list contains dups? - #- slows method down - for little benefit? - } - #!todo - test? (but we need a loop to test for integer keys.. so what's the point?) - #set intersection [struct::set intersect [dict keys $list] [dict keys $o_data]] - #if {[llength $intersection]} { - # error "keys '$intersection' already present in this collection. No items added." - #} - - - #rely on dict ordering guarantees (post 8.5? preserves order?) - set o_data [dict merge $o_data[set o_data {}] $list] - - set o_count [dict size $o_data] - - return [expr {$o_count - 1}] -} -$COL .. PatternMethod addList {list} { - var o_data o_count - - foreach val $list { - dict set o_data "_[::patternlib::uniqueKey]_" $val - #!todo - test. Presumably lappend faster because we don't need to check existing keys.. - #..but.. is there shimmering involved in treating o_data as a list? - #lappend o_data _[::patternlib::uniqueKey]_ $val - - #tested 2008-06 tcl8.6a0 lappend was slower as the gain is lost (and more!) during subsequent [dict size $o_data] - } - set o_count [dict size $o_data] - - return [expr {$o_count - 1}] -} - -#'del' is not a very good name... as we're not really 'deleting' anything. -# 'remove' seems better, and appears to be more consistent with other languages' collection implementations. -#!todo - handle 'endRange' parameter for removing ranges of items. -$COL .. PatternMethod del {idx {endRange ""}} { - var - #!todo - emit a deprecation warning for 'del' - tailcall remove $_ID_ $idx $endRange -} - -$COL .. PatternMethod remove {idx {endRange ""}} { - var o_data o_count o_alias this - - if {[string length $endRange]} { - error "ranged removal not yet implemented.. remove one item at a time." - } - - - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - set key [lindex [dict keys $o_data] $idx] - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - if {$posn < 0} { - if {[catch {set o_alias($key)} nextKey]} { - error "no such index: '$idx' in collection: $this" - } else { - #try with next key in alias chain... - #return [remove $_ID_ $nextKey] - tailcall remove $_ID_ $nextKey - } - } - } - - dict unset o_data $key - - set o_count [dict size $o_data] - return -} - -#ordered -$COL .. PatternMethod names {{globOrIdx {}}} { - var o_data - - if {[llength $globOrIdx]} { - if {[string is integer -strict $globOrIdx]} { - #Idx - set idx $globOrIdx - - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - - - - if {[catch {lindex [dict keys $o_data] $idx} result]} { - error "no such index : '$idx'" - } else { - return $result - } - - } else { - #glob - return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] - } - } else { - return [dict keys $o_data] - } -} - -#ordered -$COL .. PatternMethod keys {} { - #like 'names' but without globbing - var o_data - dict keys $o_data -} - -#Unfortunately the string 'name' is highly collidable when mixing in a collection over existing objects -# - !todo - review. Is it worth adjusting the collection methodnames to avoid a few common collision cases? -# - some sort of resolution order/interface-selection is clearly required anyway -# so perhaps it's generally best not to bother being 'polite' here, and implement a robust understandable resolution mechanism. -# In the mean time however... we'll at least avoid 'name'! -# -#$PM name {{posn 0}} { -# var o_array o_list -# -# if {$posn < 0} { -# set posn "end-[expr {abs($posn + 1)}]" -# } -# -# if {[catch {lindex $o_list $posn} result]} { -# error "no such index : '$posn'" -# } else { -# return $result -# } -#} - -$COL .. PatternMethod key {{posn 0}} { - var o_data - - if {$posn < 0} { - set posn "end-[expr {abs($posn + 1)}]" - } - - if {[catch {lindex [dict keys $o_data] $posn} result]} { - error "no such index : '$posn'" - } else { - return $result - } -} - - -#!todo - consider use of 'end-x' syntax for 'to', and implications re consistency with other commands. -$COL .. PatternMethod setPosn {idx to} { - var o_data - - if {![string is integer -strict $to]} { - error "destination position must be numeric, consider reKey method if you are trying to change the string key under which this value is stored" - } - - if {[string is integer -strict $idx]} { - set idx [expr {$idx % [dict size $o_data]}] - - set key [lindex [dict keys $o_data] $idx] - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - } - - set to [expr {$to % [dict size $o_data]}] - - - set val [dict get $o_data $key] - dict unset o_data $key - - #treat dict as list - set o_data [linsert $o_data[set o_data {}] [expr {$posn*2}] $key $val] - - #set o_list [lreplace $o_list $posn $posn] - #set o_list [linsert $o_list $to $key] - - return $to -} -#!todo - improve efficiency of calls to other functions on this object.. 'inline'?? -#presumably the collection object functionality will be long-term stable because it's purpose is to be a core datastructure; therefore it should be reasonable to favour efficiency over maintainability. -$COL .. PatternMethod incrPosn {idx {by 1}} { - var o_data - if {[string is integer -strict $idx]} { - set idx [expr {$idx % [dict size $o_data]}] - set key [lindex [dict keys $o_data] $idx] - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - } - - set newPosn [expr {($posn + $by) % [dict size $o_data]}] - - setPosn $_ID_ $posn $newPosn - return $newPosn -} -$COL .. PatternMethod decrPosn {idx {by 1}} { - var - return [incrPosn $_ID_ $idx [expr {- $by}]] -} -$COL .. PatternMethod move {idx to} { - var - return [setPosn $_ID_ $idx $to] -} -$COL .. PatternMethod posn {key} { - var o_data - return [lsearch -exact [dict keys $o_data] $key] -} - -#!todo? - disallow numeric values for newKey so as to be consistent with add -#!note! - item can be reKeyed out from under an alias such that the alias chain no longer points to anything -# - this is ok. -$COL .. PatternMethod reKey {idx newKey} { - var o_data o_alias - - - if {[dict exists $o_data $newKey]} { - #puts stderr "==============> reKey collision, key $newKey already exists in this collection" - error "reKey collision, key '$newKey' already exists in this collection" - } - if {[info exists o_alias($newKey)]} { - if {[dict exists $o_data $o_alias($newKey)]} { - error "reKey collision, key '$newKey' already present as an alias in this collection" - } else { - set newKey $o_alias($newKey) - } - } - - - - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - set key [lindex [dict keys $o_data] $idx] - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - if {$posn < 0} { - if {[catch {set o_alias($key)} nextKey]} { - error "no such index: '$idx'" - } else { - #try with next key in alias chain... - #return [reKey $_ID_ $nextKey $newKey] - tailcall reKey $_ID_ $nextKey $newKey - } - } - } - - #set o_list [lreplace $o_list $posn $posn $newKey] - ##atomic? (traces on array?) - #set o_array($newKey) $o_array($key) - #unset o_array($key) - - dict set o_data $newKey [dict get $o_data $key] - dict unset o_data $key - - return -} -$COL .. PatternMethod hasKey {key} { - var o_data - dict exists $o_data $key -} -$COL .. PatternMethod hasAlias {key} { - var o_alias - info exists o_alias($key) -} - -#either key or alias -$COL .. PatternMethod hasIndex {key} { - var o_data o_alias - if {[dict exists $o_data $key]} { - return 1 - } else { - return [info exists o_alias($key)] - } -} - - -#Shuffle methods from http://mini.net/tcl/941 -$COL .. PatternMethod shuffleFast {} { - #shuffle6 - fast, but some orders more likely than others. - - var o_data - - set keys [dict keys $o_data] - - set n [llength $keys] - for { set i 1 } { $i < $n } { incr i } { - set j [expr { int( rand() * $n ) }] - set temp [lindex $keys $i] - lset keys $i [lindex $keys $j] - lset keys $j $temp - } - - #rebuild dict in new order - #!todo - can we do the above 'in place'? - set newdata [dict create] - foreach k $keys { - dict set newdata $k [dict get $o_data $k] - } - set o_data $newdata - - return -} -$COL .. PatternMethod shuffle {} { - #shuffle5a - - var o_data - - set n 1 - set keys [list] ;#sorted list of keys - foreach k [dict keys $o_data] { - #set index [expr {int(rand()*$n)}] - - #set slist [linsert [::pattern::K $keys [set keys {}]] $index $k] - - #faster alternative.. 'inline K' [lindex [list a b] 0] ~ [K a b] - set keys [linsert [lindex [list $keys [set keys {}]] 0] [expr {int(rand()*$n)}] $k] - incr n - } - - #rebuild dict in new order - #!todo - can we do the above 'in place'? - set newdata [dict create] - foreach k $keys { - dict set newdata $k [dict get $o_data $k] - } - set o_data $newdata - - return -} - - -#search is a somewhat specialised form of 'itemKeys' -$COL .. PatternMethod search {value args} { - var o_data - #only search on values as it's possible for keys to match - especially with options such as -glob - set matches [lsearch {*}$args [dict values $o_data] $value] - - if {"-inline" in $args} { - return $matches - } else { - set keylist [list] - foreach i $matches { - set idx [expr {(($i + 1) * 2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } -} - -#inverse lookup -$COL .. PatternMethod itemKeys {value} { - var o_data - #only search on values as it's possible for keys to match - set value_indices [lsearch -all [dict values $o_data] $value] - - set keylist [list] - foreach i $value_indices { - set idx [expr {(($i + 1) * 2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist -} - -#invert: -#change collection to be indexed by its values with the old keys as new values. -# - keys of duplicate values become a list keyed on the value. -#e.g the array equivalent is: -# arr(a) 1 -# arr(b) 2 -# arr(c) 2 -#becomes -# inv(1) a -# inv(2) {b c} -#where the order of duplicate-value keys is not defined. -# -#As the total number of keys may change on inversion - order is not preserved if there are ANY duplicates. -# - - -#!todo - try just [lreverse $o_data] ?? - - -$COL .. PatternMethod invert {{splitvalues ""}} { - - var o_data o_count o_dupes o_inverted - - - if {$splitvalues eq ""} { - #not overridden - use o_dupes from last call to determine if values are actually keylists. - if {$o_dupes > 0} { - set splitvalues 1 - } else { - set splitvalues 0 - } - } - - - #set data [array get o_array] - set data $o_data - - if {$o_count > 500} { - #an arbitrary optimisation for 'larger' collections. - #- should theoretically keep the data size and save some reallocations. - #!todo - test & review - # - foreach nm [dict keys $o_data] { - dict unset o_data $nm - } - } else { - set o_data [dict create] - } - - if {!$splitvalues} { - dict for {k v} $data { - dict set o_data $v $k - } - } else { - dict for {k v} $data { - #we're splitting values because each value is a list of keys - #therefore sub should be unique - no need for lappend in this branch. - foreach sub $v { - #if {[info exists o_array($sub)]} { - # puts stderr "---here! v:$v sub:$sub k:$k" - # lappend o_array($sub) $k - #} else { - dict set o_data $sub $k - #} - } - } - } - - - if {[dict size $o_data] != $o_count} { - #must have been some dupes - - set o_dupes [expr {$o_count - [dict size $o_data]}] - #update count to match inverted collection - set o_count [dict size $o_data] - } else { - set o_dupes 0 - } - - set o_inverted [expr {!$o_inverted}] - - #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' - return $o_dupes -} - - - - - - -#NOTE: values are treated as lists and split into separate keys for inversion only if requested! -# To treat values as keylists - set splitvalues 1 -# To treat each value atomically - set splitvalues 0 -# i.e only set splitvalues 1 if you know the values represent duplicate keys from a previous call to invert! -# -# -#Initially call invert with splitvalues = 0 -#To keep calling invert and get back where you started.. -# The rule is... if the previous call to invert returned > 0... pass 1 on the next call. -# -$COL .. PatternMethod invert_manual {{splitvalues 0}} { - #NOTE - the list nesting here is *tricky* - It probably isn't broken. - - var o_list o_array o_count - - set data [array get o_array] - - if {$o_count > 500} { - #an arbitrary optimisation for 'large' collections. - #- should theoretically keep the array size and save some reallocations. - #!todo - test & review - # - foreach nm [array names o_array] { - unset o_array($nm) - } - } else { - array unset o_array - } - - if {!$splitvalues} { - foreach {k v} $data { - lappend o_array($v) $k - } - } else { - foreach {k v} $data { - #we're splitting values because each value is a list of keys - #therefore sub should be unique - no need for lappend in this branch. - foreach sub $v { - #if {[info exists o_array($sub)]} { - # puts stderr "---here! v:$v sub:$sub k:$k" - # lappend o_array($sub) $k - #} else { - set o_array($sub) $k - #} - } - } - } - - - if {[array size o_array] != $o_count} { - #must have been some dupes - set o_list [array names o_array] - - - set dupes [expr {$o_count - [array size o_array]}] - #update count to match inverted collection - set o_count [array size o_array] - } else { - #review - are these machinations worthwhile for order preservation? what speed penalty do we pay? - array set prev $data - set i -1 - if {$splitvalues} { - #values are lists of length one. Take lindex 0 so list values aren't overnested. - foreach oldkey $o_list { - lset o_list [incr i] [lindex $prev($oldkey) 0] - } - } else { - foreach oldkey $o_list { - lset o_list [incr i] $prev($oldkey) - } - } - - set dupes 0 - } - - - #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' - return $dupes -} - - - -#Note that collections cannot be inverted without loss of information if they have duplicates AND compound keys -# (keys that are lists) -$COL .. PatternMethod invert_lossy {{splitvalues 1}} { - var o_list o_array o_count - - set data [array get o_array] - - if {$o_count > 500} { - #an arbitrary optimisation for 'large' collections. - #- should theoretically keep the array size and save some reallocations. - #!todo - test & review - # - foreach nm [array names o_array] { - unset o_array($nm) - } - } else { - array unset o_array - } - - if {!$splitvalues} { - foreach {k v} $data { - #note! we must check for existence and use 'set' for first case. - #using 'lappend' only will result in deeper nestings on each invert! - #If you don't understand this - don't change it! - if {[info exists o_array($v)]} { - lappend o_array($v) $k - } else { - set o_array($v) $k - } - } - } else { - foreach {k v} $data { - #length test necessary to avoid incorrect 'un-nesting' - #if {[llength $v] > 1} { - foreach sub $v { - if {[info exists o_array($sub)]} { - lappend o_array($sub) $k - } else { - set o_array($sub) $k - } - } - #} else { - # if {[info exists o_array($v)]} { - # lappend o_array($v) $k - # } else { - # set o_array($v) $k - # } - #} - } - } - - - if {[array size o_array] != $o_count} { - #must have been some dupes - set o_list [array names o_array] - - - set dupes [expr {$o_count - [array size o_array]}] - #update count to match inverted collection - set o_count [array size o_array] - } else { - #review - are these machinations worthwhile for order preservation? what speed penalty do we pay? - array set prev $data - set i -1 - foreach oldkey $o_list { - lset o_list [incr i] $prev($oldkey) - } - set dupes 0 - } - - - #'dupes' is the size difference - so 3 equal values in the original collection corresponds to '2 dupes' - return $dupes -} - -$COL .. PatternMethod reverse {} { - var o_data - - set dictnew [dict create] - foreach k [lreverse [dict keys $o_data]] { - dict set dictnew $k [dict get $o_data $k] - } - set o_data $dictnew - return -} - -$COL .. PatternMethod keySort {{options -ascii}} { - var o_data - - set keys [lsort {*}$options [dict keys $o_data]] - - set dictnew [dict create] - foreach k $keys { - dict set dictnew $k [dict get $o_data $k] - } - set o_data $dictnew - - return -} - -#!todo - allow simple options in combination with options such as -command and -object. Redo args handling completely for more complex sorting. -$COL .. PatternMethod sort {args} { - var o_data - - #defaults - set options [dict create -index 1] ;#values always in subelement 1 of name-value pair list for sorting. - - set options_simple [list] - - - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - switch -- $a { - -indices - - -ascii - - -dictionary - - -integer - - -real - - -increasing - - -decreasing { - #dict set options $a 1 - lappend options_simple $a - } - -unique { - #not a valid option - #this would stuff up the data... - #!todo? - remove dups from collection if this option used? - alias the keys? - } - -object { - #!todo - treat value as object and allow sorting by sub-values .eg >col1 . sort -object ". sub . property" -increasing - #may be slow - but handy. Consider -indexed property to store/cache these values on first run - } - -command { - dict set options $a [lindex $args [incr i]] - } - -index { - #allow sorting on subindices of the value. - dict set options -index [concat [dict get $options -index] [lindex $args [incr i]] ] - } - default { - #unrecognised option - print usage? - } - } - } - - - - if {[set posn [lsearch -exact $options_simple "-indices"]] >= 0} { - - var o_array - - set slist [list] - foreach k [dict keys $o_data] { - lappend slist [list $k [dict get $o_data $k]] - } - return [lsort {*}$options_simple {*}$options $slist] - - - - #set options_simple [lreplace $options_simple $posn $posn] ;# - #set slist [list] - #foreach {n v} [array get ::p::[lindex ${_ID_} 0 0]::o_array] { - # lappend slist [list $n $v] - #} - #set slist [lsort {*}$options_simple {*}$options $slist] - #foreach i $slist { - # #determine the position in the collections list - # lappend result {*}[lsearch -exact $o_list [lindex $i 0]] - #} - #return $result - } else { - set slist [list] - dict for {k v} $o_data { - lappend slist [list $k $v] - } - #set slist [lsort {*}$options_simple {*}$options $slist] - set slist [lsort {*}$options_simple {*}$options $slist[set slist {}]] ;#K combinator for efficiency - - - #set o_list [lsearch -all -inline -subindices -index 0 $slist *] - - set o_data [dict create] - foreach pair $slist { - dict set o_data [lindex $pair 0] [lindex $pair 1] - } - - - - return - } - -} - - -$COL .. PatternMethod clear {} { - var o_data o_count - - set o_data [dict create] - set o_count 0 - #aliases? - return -} - -#see http://wiki.tcl.tk/15271 - A generic collection traversal interface -# -#!todo - options: -progresscommand -errorcommand (-granularity ?) (-self ? (to convert to an iterator?)) -#!todo? - lazy retrieval of items so that all changes to the collection are available to a running asynch enumeration? -# - should this be an option? which mechanism should be the default? -# - currently only the keylist is treated in 'snapshot' fashion -# so values could be changed and the state could be invalidated by other code during an enumeration -# -$COL .. PatternMethod enumerate {args} { - #---------- - lassign [lrange $args end-1 end] cmd seed - set optionlist [list] - foreach a [lrange $args 0 end-2] { - lappend optionlist $a - } - set opt(-direction) left - set opt(-completioncommand) "" - array set opt $optionlist - #---------- - var o_data - - if {[string tolower [string index $opt(-direction) 0]] eq "r"} { - #'right' 'RIGHT' 'r' etc. - set list [lreverse [dict keys $o_data]] - } else { - #normal left-right order - set list [dict keys $o_data] - } - - if {![string length $opt(-completioncommand)]} { - #standard synchronous processing - foreach k $list { - set seed [uplevel #0 [list {*}$cmd $seed [dict get $o_data $k]]] - } - return $seed - } else { - #ASYNCHRONOUS enumeration - var this o_bgEnum - #!todo - make id unique - #!todo - facility to abort running enumeration. - set enumID enum[array size o_bgEnum] - - set seedvar [$this . bgEnum $enumID .] - set $seedvar $seed - - after 0 [list $this . _doBackgroundEnum $enumID $list $cmd $seedvar $opt(-completioncommand)] - return $enumID - } -} - -#!todo - make private? - put on a separate interface? -$COL .. PatternMethod _doBackgroundEnum {enumID slice cmd seedvar completioncommand} { - var this o_data - - - #Note that we don't post to the eventqueue using 'foreach s $slice' - # we only schedule another event after each item is processed - # - otherwise we would be spamming the eventqueue with items. - - #!todo? - accept a -granularity option to allow handling of n list-items per event? - - if {[llength $slice]} { - set slice [lassign $slice head] - - set script [string map [list %cmd% $cmd %seedvar% $seedvar %val% [dict get $o_data $head]] { - %cmd% [set %seedvar%] %val% - }] - - #post to eventqueue and re-enter _doBackgroundEnum - # - after idle [list after 0 [subst {set $seedvar \[uplevel #0 [list $script] \]; $this . _doBackgroundEnum $enumID [list $slice] [list $cmd] $seedvar [list $completioncommand]}]] - - } else { - #done. - - set script [string map [list %cmd% $completioncommand %seedvar% $seedvar] { - lindex [list [%cmd% [set %seedvar%]] [unset %seedvar%]] 0 - }] - - after idle [list after 0 [list uplevel #0 $script]] - } - - return -} - -$COL .. PatternMethod enumeratorstate {} { - var o_bgEnum - parray o_bgEnum -} - -#proc ::bgerror {args} { -# puts stderr "=bgerror===>$args" -#} - - -#map could be done in terms of the generic 'enumerate' method.. but it's slower. -# -#$PM map2 {proc} { -# var -# enumerate $_ID_ [list ::map-helper $proc] [list] -#} -#proc ::map-helper {proc accum item} { -# lappend accum [uplevel #0 [list {*}$proc $item]] -#} - -$COL .. PatternMethod map {cmd} { - var o_data - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list {*}$cmd $v]] - } - - return $seed -} -$COL .. PatternMethod objectmap {cmd} { - var o_data - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list $v {*}$cmd]] - } - - return $seed -} - - -#End core collection functionality. -#collection 'mixin' interfaces - ->pattern .. Create >keyvalprotector ->keyvalprotector .. PatternVariable o_protectedkeys ->keyvalprotector .. PatternVariable o_protectedvals - -#!todo - write test regarding errors in Constructors for mixins like this -# - an error (e.g from bad args) can cause errors with vars after it's re-run with correct args ->keyvalprotector .. Constructor {args} { - var this o_protectedkeys o_protectedvals - set this @this@ - #---------------------------------------------------------------------------- - set known_opts [list -keys -vals ] - dict set default -keys [list] - dict set default -vals [list] - if {([llength $args] % 2) != 0} { - error "(>keyvalprotector .. Constructor) ERROR: uneven options supplied - must be of form '-option value' " - } - foreach {k v} $args { - if {$k ni $known_opts} { - error "(>keyvalprotector .. Constructor) ERROR: option '$k' not in known options: '$known_opts'" - } - } - set opts [dict merge $default $args] - set o_protectedkeys [dict get $opts -keys] - set o_protectedvals [dict get $opts -vals] - #---------------------------------------------------------------------------- - set protections [concat $o_protectedkeys $o_protectedvals] - if {![llength $protections]} { - error "(>keyvalprotector .. Constructor) ERROR: must supply at least one argument to -vals or -keys" - } - -} ->keyvalprotector .. PatternMethod clear {} { - error "(>keyvalprotector . clear) ERROR: This collection is protected by a >keyvalprotector mixin. Cannot clear" -} ->keyvalprotector .. PatternMethod pop {{idx ""}} { - var o_data o_count o_protectedkeys o_protectedvals - - if {$idx eq ""} { - set key [lindex [dict keys $o_data] end] - } else { - if {[string is integer -strict $idx]} { - set key [lindex [dict keys $o_data] $idx] - } else { - set key $idx - } - } - - if {$key in $o_protectedkeys} { - error "(>keyvalprotector . pop) ERROR: Cannot pop object with index '$idx', key '$key' from collection." - } - set posn [lsearch -exact [dict keys $o_data] $key] - if {($posn >= 0) && ($posn < [dict size $o_data])} { - set result [dict get $o_data $key] - if {$result in $o_protectedvals} { - error "(>keyvalprotector . pop) ERROR: Cannot pop object '$result' with index '$idx', key '$key' from collection." - } - dict unset o_data $key - set o_count [dict size $o_data] - return $result - } else { - error "no such index: '$idx'" - } - -} ->keyvalprotector .. PatternMethod remove {idx {endRange ""}} { - var this o_data o_count o_alias o_protectedkeys o_protectedvals - - if {[string length $endRange]} { - error "ranged removal not yet implemented.. remove one item at a time." - } - - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - set key [lindex [dict keys $o_data] $idx] - if {$key in $o_protectedkeys} { - error "(>keyvalprotector . remove) ERROR: cannot remove item with index '$idx' key '$key' from collection" - } - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - if {$posn < 0} { - if {[catch {set o_alias($key)} nextKey]} { - error "no such index: '$idx' in collection: $this" - } else { - if {$key in $o_protectedkeys} { - error "(>keyvalprotector . remove) ERROR: cannot remove item with index '$idx' from collection" - } - #try with next key in alias chain... - #return [remove $_ID_ $nextKey] - tailcall remove $_ID_ $nextKey - } - } - } - - dict unset o_data $key - - set o_count [dict size $o_data] - return -} - -#1) -#predicate methods (order preserving) -#usage: -# >collection .. Create >c1 -# >predicatedCollection .. Create >c1 ;#overlay predicate methods on existing collection - -#e.g >col1 . all {$val > 14} -#e.g >col1 . filterToCollection {$val > 19} . count -#e.g >col1 . filter {[string match "x*" $key]} -#!todo - fix. currying fails.. - -::>pattern .. Create >predicatedCollection -#process_pattern_aliases ::patternlib::>predicatedCollection - -set PM [>predicatedCollection .. PatternMethod .] - ->predicatedCollection .. PatternMethod filter {predicate} { - var this o_list o_array - set result [list] - - #!note (jmn 2004) how could we do smart filtering based on $posn? - #i.e it would make sense to lrange $o_list based on $posn... - #but what about complicated expressions where $posn is a set of ranges and/or combined with tests on $key & $val ?? - #Seems better to provide an alternative efficient means of generating subcolllections/ranges to perform predicate operations upon. - #given this, is $posn even useful? - - set posn 0 - foreach key $o_list { - set val $o_array($key) - if $predicate { - lappend result $val - } - incr posn - } - set result -} ->predicatedCollection .. PatternMethod filterToKeys {predicate} { - var this o_list o_array - set result [list] - - set posn 0 - foreach key $o_list { - set val $o_array($key) - if $predicate { - lappend result $key - } - incr posn - } - set result -} ->predicatedCollection .. PatternMethod filterToCollection {predicate {destCollection {}}} { - #!todo - collection not in subordinate namespace? -> if subordinate, should imply modification of sub's contents will be reflected in parent? - #!todo - implement as 'view' on current collection object.. extra o_list variables? - #!todo - review/document 'expected' key collision behaviour - source keys used as dest keys.. -autokey option required? - var this o_list o_array m_i_filteredCollection - - incr m_i_filteredCollection - if {![string length $destCollection]} { - #!todo? - implement 'one-shot' object (similar to RaTcl) - set result [::patternlib::>collection .. Create [$this .. Namespace]::>filteredCollection-$m_i_filteredCollection] - } else { - set result $destCollection - } - - #### - #externally manipulate new collection - #set ADD [$c . add .] - #foreach key $o_list { - # set val $o_array($key) - # if $predicate { - # $ADD $val $key - # } - #} - ### - - #internal manipulation faster - #set cID [lindex [set $result] 0] - set cID [lindex [$result --] 0] - - #use list to get keys so as to preserve order - set posn 0 - upvar #0 ::p::${cID}::o_array cARRAY ::p::${cID}::o_list cLIST - foreach key $o_list { - set val $o_array($key) - if $predicate { - if {[info exists cARRAY($key)]} { - error "key '$key' already exists in this collection" - } - lappend cLIST $key - set cARRAY($key) $val - } - incr posn - } - - return $result -} - -#NOTE! unbraced expr/if statements. We want to evaluate the predicate. ->predicatedCollection .. PatternMethod any {predicate} { - var this o_list o_array - set posn 0 - foreach key $o_list { - set val $o_array($key) - if $predicate { - return 1 - } - incr posn - } - return 0 -} ->predicatedCollection .. PatternMethod all {predicate} { - var this o_list o_array - set posn 0 - foreach key $o_list { - set val $o_array($key) - if !($predicate) { - return 0 - } - incr posn - } - return 1 -} ->predicatedCollection .. PatternMethod dropWhile {predicate} { - var this o_list o_array - set result [list] - set _idx 0 - set posn 0 - foreach key $o_list { - set val $o_array($key) - if $predicate { - incr _idx - } else { - break - } - incr posn - } - set remaining [lrange $o_list $_idx end] - foreach key $remaining { - set val $o_array($key) - lappend result $val - } - return $result -} ->predicatedCollection .. PatternMethod takeWhile {predicate} { - var this o_list o_array - set result [list] - set posn 0 - foreach key $o_list { - set val $o_array($key) - if $predicate { - lappend result $val - } else { - break - } - incr posn - } - set result -} - - - -#end >collection mixins -###################################### - - - - -#----------------------------------------------------------- -#!TODO - methods for converting an arrayHandle to & from a hashMap efficiently? -# Why do we need both? apart from the size variable, what is the use of hashMap? -#----------------------------------------------------------- -#::pattern::create >hashMap -::>pattern .. Create >hashMap - ->hashMap .. PatternVariable o_size ->hashMap .. PatternVariable o_array - ->hashMap .. Constructor {args} { - var o_array o_size - array set o_array [list] - set o_size 0 -} ->hashMap .. PatternDefaultMethod "item" ->hashMap .. PatternMethod item {key} { - var o_array - set o_array($key) -} ->hashMap .. PatternMethod items {} { - var o_array - - set result [list] - foreach nm [array names o_array] { - lappend result $o_array($nm) - } - return $result -} ->hashMap .. PatternMethod pairs {} { - var o_array - - array get o_array -} ->hashMap .. PatternMethod add {val key} { - var o_array o_size - - set o_array($key) $val - incr o_size - return $key -} - ->hashMap .. PatternMethod del {key} { - var - puts stderr "warning: 'del' method of >hashMap deprecated. Use 'remove' instead." - remove $_ID_ $key -} ->hashMap .. PatternMethod remove {key} { - var o_array o_size - unset o_array($key) - incr o_size -1 - return $key -} ->hashMap .. PatternMethod count {} { - var o_size - #array size o_array - return $o_size -} ->hashMap .. PatternMethod count2 {} { - var o_array - #array size o_array ;#slow, at least for TCLv8.4.4 - #even array statistics is faster than array size ! - #e.g return [lindex [array statistics o_array] 0] - #but.. apparently there are circumstances where array statistics doesn't report the correct size. - return [array size o_array] -} ->hashMap .. PatternMethod names {} { - var o_array - array names o_array -} ->hashMap .. PatternMethod keys {} { - #synonym for names - var o_array - array names o_array -} ->hashMap .. PatternMethod hasKey {key} { - var o_array - return [info exists o_array($key)] -} ->hashMap .. PatternMethod clear {} { - var o_array o_size - unset o_array - set o_size 0 - return -} -#>hashMap .. Ready 1 - - - - - - - - - - - - - - - -#explicitly create metadata. Not required for user-defined patterns. -# this is only done here because this object is used for the metadata of all objects -# so the object must have all it's methods/props before its own metadata structure can be built. -#uplevel 1 "::pattern::object ::pattern::>_nullMeta createMetadata >collection" -#uplevel 1 "::patternlib::>collection .. CreateMetadata ::patternlib::>collection" - - - - -if 0 { - - -#----------------------------------------------------------- -#::pattern::create >arrayHandle { -# variable o_arrayName -# variable this -#} -::>pattern .. Create >arrayHandle - ->arrayHandle .. PatternVariable o_arrayName ->arrayHandle .. PatternVariable this - ->arrayHandle .. Constructor {args} { - var o_arrayName this - set this @this@ - - - set o_arrayName [$this .. Namespace]::array - - upvar #0 $o_arrayName $this - #? how to automatically update this after a namespace import? - - array set $o_arrayName [list] - -} ->arrayHandle .. PatternMethod array {} { - var o_arrayName - return $o_arrayName -} - -#------------------------------------------------------- -#---- some experiments ->arrayHandle .. PatternMethod up {varname} { - var o_arrayName - - #is it dodgy to hard-code the calling depth? - #will it be different for different object systems? - #Will it even be consistent for the same object. - # Is this method necessary anyway? - - # - users can always instead do: - # upvar #0 [>instance . array] var - - uplevel 3 [list upvar 0 $o_arrayName $varname] - - return -} ->arrayHandle .. PatternMethod global {varname} { - var o_arrayName - # upvar #0 [>instance . array] var - - if {![string match ::* $varname]} { - set varname ::$varname - } - - upvar #0 $o_arrayName $varname - - return -} ->arrayHandle .. PatternMethod depth {} { - var o_arrayName - # - for {set i 0} {$i < [info level]} { - puts "${i}: [uplevel $i [list namespace current] , [info level $i]]" - } - -} - # -------------------------------------------- - - ->arrayHandle .. PatternMethod item {key} { - var o_arrayName - set ${o_arrayName}($key) -} ->arrayHandle .. PatternMethod items {} { - var o_arrayName - - set result [list] - foreach nm [array names $o_arrayName] { - lappend result [set ${o_arrayName}($nm)] - } - return $result -} ->arrayHandle .. PatternMethod pairs {} { - var o_arrayName - - array get $o_arrayName -} ->arrayHandle .. PatternMethod add {val key} { - var o_arrayName - - set ${o_arrayName}($key) $val - return $key -} ->arrayHandle .. PatternMethod del {key} { - puts stderr "Warning: 'del' method of >arrayHandle deprecated. Use 'remove' instead." - remove $_ID_ $key -} ->arrayHandle .. PatternMethod remove {key} { - var o_arrayName - unset ${o_arrayName}($key) - return $key -} ->arrayHandle .. PatternMethod size {} { - var o_arrayName - return [array size $o_arrayName] -} ->arrayHandle .. PatternMethod count {} { - #alias for size - var o_arrayName - return [array size $o_arrayName] -} ->arrayHandle .. PatternMethod statistics {} { - var o_arrayName - return [array statistics $o_arrayName] -} ->arrayHandle .. PatternMethod names {} { - var o_arrayName - array names $o_arrayName -} ->arrayHandle .. PatternMethod keys {} { - #synonym for names - var o_arrayName - array names $o_arrayName -} ->arrayHandle .. PatternMethod hasKey {key} { - var o_arrayName - - return [info exists ${o_arrayName}($key)] -} ->arrayHandle .. PatternMethod clear {} { - var o_arrayName - unset $o_arrayName - array set $o_arrayName [list] - - return -} -#>arrayHandle .. Ready 1 - - - - -::>pattern .. Create >matrix - ->matrix .. PatternVariable o_array ->matrix .. PatternVariable o_size - ->matrix .. Constructor {args} { - var o_array o_size - - array set o_array [list] - set o_size 0 -} - - -#process_pattern_aliases ::patternlib::>matrix - -set PM [>matrix .. PatternMethod .] - ->matrix .. PatternMethod item {args} { - var o_array - - if {![llength $args]} { - error "indices required" - } else { - - } - if [info exists o_array($args)] { - return $o_array($args) - } else { - error "no such index: '$args'" - } -} ->matrix .. PatternMethod items {} { - var o_array - - set result [list] - foreach nm [array names o_array] { - lappend result $o_array($nm) - } - return $result -} ->matrix .. PatternMethod pairs {} { - var o_array - - array get o_array -} ->matrix .. PatternMethod slice {args} { - var o_array - - if {"*" ni $args} { - lappend args * - } - - array get o_array $args -} ->matrix .. PatternMethod add {val args} { - var o_array o_size - - if {![llength $args]} { - error "indices required" - } - - set o_array($args) $val - incr o_size - - #return [array size o_array] - return $o_size -} ->matrix .. PatternMethod names {} { - var o_array - array names o_array -} ->matrix .. PatternMethod keys {} { - #synonym for names - var o_array - array names o_array -} ->matrix .. PatternMethod hasKey {args} { - var o_array - - return [info exists o_array($args)] -} ->matrix .. PatternMethod clear {} { - var o_array o_size - unset o_array - set o_size 0 - return -} ->matrix .. PatternMethod count {} { - var o_size - return $o_size -} ->matrix .. PatternMethod count2 {} { - var o_array - #see comments for >hashMap count2 - return [array size o_array] -} -#>matrix .. Ready 1 - -#-------------------------------------------------------- -#tree data structure (based *loosely* on API at http://www.msen.com/%7Eclif/treeNobj.html - discussed in Clif Flynts book Tcl programming) -#!todo - compare API to http://tcllib.sourceforge.net/doc/tree.html -#!todo - create an >itree (inheritance tree) where node data is readable/writable on children unless overridden. -::>pattern .. Create >tree - -set _NODE [::>pattern .. Create [>tree .. Namespace]::>node] -set _TREE_NODE $_NODE -#process_pattern_aliases $_TREE_NODE - -$_NODE .. PatternVariable o_treens ;#tree namespace -$_NODE .. PatternVariable o_idref -$_NODE .. PatternVariable o_nodePrototype - -#$_NODE .. PatternProperty data -$_NODE .. PatternProperty info - -$_NODE .. PatternProperty tree -$_NODE .. PatternProperty parent -$_NODE .. PatternProperty children -$_NODE .. PatternMethod addNode {} { - set nd_id [incr $o_idref] - set nd [$o_nodePrototype .. Create ${o_treens}::>n-$nd_id -tree $o_tree -parent @this@] - @this@ . add $nd n-$nd_id - - return n-$nd_id -} -#flat list of all nodes below this -#!todo - something else? ad-hoc collections? -#!todo - non-recursive version? tail-call opt? -$_NODE .. PatternMethod nodes {} { - set result [list] - - #use(abuse?) our knowledge of >collection internals - foreach n $o_list { - #eval lappend result $n [$o_array($n) . nodes] - #!todo - test - lappend result $n {*}[$o_array($n) . nodes] - } - return $result -} -#count of number of descendants -#!todo - non-recursive version? tail-call opt? -$_NODE .. PatternMethod size {} { - set result 0 - #use(abuse?) our knowledge of >collection internals - foreach n $o_list { - incr result [expr {1 + [$o_array($n) . size]}] - } - return $result -} -$_NODE .. PatternMethod isLeaf {} { - #!todo - way to stop unused vars being uplevelled? - var o_tree - - #tailcall isEmpty $_ID_ ;#fails. because isEmpty is from >collection interface - so different ns? - tailcall [@this@ . isEmpty .] -} -$_NODE .. Constructor {args} { - array set A $args - - set o_tree $A(-tree) - set o_parent $A(-parent) - - #array set o_data [list] - array set o_info [list] - - set o_nodePrototype [::patternlib::>tree .. Namespace]::>node - set o_idref [$o_tree . nodeID .] - set o_treens [$o_tree .. Namespace] - #set o_children [::patternlib::>collection .. Create [@this@ .. Namespace]::>children] - - #overlay children collection directly on the node - set o_children [::patternlib::>collection .. Create @this@] - - return -} - ->tree .. PatternProperty test blah ->tree .. PatternProperty nodeID 0 ;#public only so node can access.. need 'friend' concept? ->tree .. PatternVariable o_ns ->tree .. Constructor {args} { - set o_ns [@this@ .. Namespace] - - #>tree is itself also a node (root node) - #overlay new 'root' node onto existing tree, pass tree to constructor - [::patternlib::>tree .. Namespace]::>node .. Create @this@ -tree @this@ -parent "" -} - - - - -unset _NODE - - - - -#-------------------------------------------------------- -#a basic binary search tree experiment -# - todo - 'scheme' property to change behaviour? e.g balanced tree -::>pattern .. Create >bst -#process_pattern_aliases ::patternlib::>bst ->bst .. PatternVariable o_NS ;#namespace ->bst .. PatternVariable o_this ;#namespace ->bst .. PatternVariable o_nodeID - ->bst .. PatternProperty root "" ->bst .. Constructor {args} { - set o_this @this@ - set o_NS [$o_this .. Namespace] - namespace eval ${o_NS}::nodes {} - puts stdout ">bst constructor" - set o_nodeID 0 -} ->bst .. PatternMethod insert {key args} { - set newnode [::patternlib::>bstnode .. Create ${o_NS}::nodes::>n-[incr o_nodeID]] - set [$newnode . key .] $key - if {[llength $args]} { - set [$newnode . value .] $args - } - if {![string length $o_root]} { - set o_root $newnode - set [$newnode . parent .] $o_this - } else { - set ipoint {} ;#insertion point - set tpoint $o_root ;#test point - set side {} - while {[string length $tpoint]} { - set ipoint $tpoint - if {[$newnode . key] < [$tpoint . key]} { - set tpoint [$tpoint . left] - set side left - } else { - set tpoint [$tpoint . right] - set side right - } - } - set [$newnode . parent .] $ipoint - set [$ipoint . $side .] $newnode - } - return $newnode -} ->bst .. PatternMethod item {key} { - if {![string length $o_root]} { - error "item $key not found" - } else { - set tpoint $o_root - while {[string length $tpoint]} { - if {[$tpoint . key] eq $key} { - return $tpoint - } else { - if {$key < [$tpoint . key]} { - set tpoint [$tpoint . left] - } else { - set tpoint [$tpoint . right] - } - } - } - error "item $key not found" - } -} ->bst .. PatternMethod inorder-walk {} { - if {[string length $o_root]} { - $o_root . inorder-walk - } - puts {} -} ->bst .. PatternMethod view {} { - array set result [list] - - if {[string length $o_root]} { - array set result [$o_root . view 0 [list]] - } - - foreach depth [lsort [array names result]] { - puts "$depth: $result($depth)" - } - -} -::>pattern .. Create >bstnode -#process_pattern_aliases ::patternlib::>bstnode ->bstnode .. PatternProperty parent ->bstnode .. PatternProperty left "" ->bstnode .. PatternProperty right "" ->bstnode .. PatternProperty key ->bstnode .. PatternProperty value - ->bstnode .. PatternMethod inorder-walk {} { - if {[string length $o_left]} { - $o_left . inorder-walk - } - - puts -nonewline "$o_key " - - if {[string length $o_right]} { - $o_right . inorder-walk - } - - return -} ->bstnode .. PatternMethod view {depth state} { - #!todo - show more useful representation of structure - set lower [incr depth] - - if {[string length $o_left]} { - set state [$o_left . view $lower $state] - } - - if {[string length $o_right]} { - set state [$o_right . view $lower $state] - } - - - array set s $state - lappend s($depth) $o_key - - return [array get s] -} - - -#-------------------------------------------------------- -#::pattern::create ::pattern::>metaObject -#::pattern::>metaObject PatternProperty methods -#::pattern::>metaObject PatternProperty properties -#::pattern::>metaObject PatternProperty PatternMethods -#::pattern::>metaObject PatternProperty patternProperties -#::pattern::>metaObject Constructor args { -# set this @this@ -# -# set [$this . methods .] [::>collection create [$this namespace]::methods] -# set [$this . properties .] [::>collection create [$this namespace]::properties] -# set [$this . PatternMethods .] [::>collection create [$this namespace]::PatternMethods] -# set [$this . patternProperties .] [::>collection create [$this namespace]::patternProperties] -# -#} - - - - #tidy up - unset PV - unset PM - - - -#-------------------------------------------------------- -::>pattern .. Create >enum -#process_pattern_aliases ::patternlib::>enum ->enum .. PatternMethod item {{idx 0}} { - var o_array o_list - - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - if {[catch {set o_array([lindex $o_list $idx])} result]} { - error "no such index : '$idx'" - } else { - return $result - } - } else { - if {[catch {set o_array($idx)} result]} { - error "no such index: '$idx'" - } else { - return $result - } - } -} - - - -#proc makeenum {type identifiers} { -# #!!todo - make generated procs import into whatever current system context? -# -# upvar #0 wbpbenum_${type}_number a1 wbpbenum_number_${type} a2 -# -# #obliterate any previous enum for this type -# catch {unset a1} -# catch {unset a2} -# -# set n 0 -# foreach id $identifiers { -# set a1($id) $n -# set a2($n) $id -# incr n -# } -# proc ::${type}_to_number key [string map [list @type@ $type] { -# upvar #0 wbpbenum_@type@_number ary -# if {[catch {set ary($key)} num]} { -# return -code error "unknown @type@ '$key'" -# } -# return $num -# }] -# -# proc ::number_to_${type} {number} [string map [list @type@ $type] { -# upvar #0 wbpbenum_number_@type@ ary -# if {[catch {set ary($number)} @type@]} { -# return -code error "no @type@ for '$number'" -# } -# return $@type@ -# }] -# -# #eval "namespace eval ::sysnexus {namespace export number_to_${type}; namespace export ${type}_to_number}" -# #eval "namespace eval :: {namespace import -force sysnexus::number_to_${type} sysnexus::${type}_to_number}" -#} -# -#-------------------------------------------------------- -::>pattern .. Create >nest ->nest .. PatternVariable THIS ->nest .. PatternProperty data -autoclone ->nest .. Constructor {args} { - var o_data - var THIS - set THIS @this@ - array set o_data [list] -} ->nest .. PatternMethod item {args} { - set THIS @this@ - return [$THIS . data [join $args ,]] -} - -# -# e.g -# set [>nest a , b . data c .] blah -# >nest a , b , c -# -# set [>nest w x , y . data z .] etc -# >nest w x , y , z -#-------------------------------------------------------- - -} - -} - - -#package require patternlibtemp diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm deleted file mode 100644 index 680ea88f..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/patternpredator2-1.2.4.tm +++ /dev/null @@ -1,754 +0,0 @@ -package provide patternpredator2 1.2.4 - -proc ::p::internals::jaws {OID _ID_ args} { - #puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" - #set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - yield - set w 1 - - set stack [list] - set wordcount [llength $args] - set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first - set unsupported 0 - set operator "" - set operator_prev "" ;#used only by argprotect to revert to previous operator - - - if {$OID ne "null"} { - #!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) - #upvar #0 ::p::${OID}::_meta::map MAP - set MAP [set ::p::${OID}::_meta::map] - } else { - # error "jaws - OID = 'null' ???" - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key - } - set invocantdata [dict get $MAP invocantdata] - lassign $invocantdata OID alias default_method object_command wrapped - - set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code - - #don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w - while {$w < $wordcount} { - set word [lindex $args [expr {$w -1}]] - #puts stdout "w:$w word:$word stack:$stack" - - if {$operator eq "argprotect"} { - set operator $operator_prev - lappend stack $word - incr w - } else { - if {[llength $stack]} { - if {$word in $terminals} { - set reduction [list 0 $_ID_ {*}$stack ] - #puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" - - - set _ID_ [yield $reduction] - set stack [list] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] - #puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" - } - - #review - 2018. switched to _ID_ instead of MAP - lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command - #lassign [dict get $MAP invocantdata] OID alias default_method object_command - - - #puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" - set operator $word - #don't incr w - #incr w - } else { - if {$operator eq "argprotect"} { - set operator $operator_prev - set operator_prev "" - lappend stack $word - } else { - #only look for leading argprotect chacter (-) if we're not already in argprotect mode - if {$word eq "--"} { - set operator_prev $operator - set operator "argprotect" - #Don't add the plain argprotector to the stack - } elseif {[string match "-*" $word]} { - #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) - set operator_prev $operator - set operator "argprotect" - lappend stack $word - } else { - lappend stack $word - } - } - - - incr w - } - } else { - #no stack - switch -- $word {.} { - - if {$OID ne "null"} { - #we know next word is a property or method of a pattern object - incr w - set nextword [lindex $args [expr {$w - 1}]] - set command ::p::${OID}::$nextword - set stack [list $command] ;#2018 j - set operator . - if {$w eq $wordcount} { - set finished_args 1 - } - } else { - # don't incr w - #set nextword [lindex $args [expr {$w - 1}]] - set command $object_command ;#taken from the MAP - set stack [list "_exec_" $command] - set operator . - } - - - } {..} { - incr w - set nextword [lindex $args [expr {$w -1}]] - set command ::p::-1::$nextword - #lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. - set stack [list $command] ;#faster, and intent is clearer than lappend. - set operator .. - if {$w eq $wordcount} { - set finished_args 1 - } - } {,} { - #puts stdout "Stackless comma!" - - - if {$OID ne "null"} { - set command ::p::${OID}::$default_method - } else { - set command [list $default_method $object_command] - #object_command in this instance presumably be a list and $default_method a list operation - #e.g "lindex {A B C}" - } - #lappend stack $command - set stack [list $command] - set operator , - } {--} { - set operator_prev $operator - set operator argprotect - #no stack - - } {!} { - set command $object_command - set stack [list "_exec_" $object_command] - #puts stdout "!!!! !!!! $stack" - set operator ! - } default { - if {$operator eq ""} { - if {$OID ne "null"} { - set command ::p::${OID}::$default_method - } else { - set command [list $default_method $object_command] - } - set stack [list $command] - set operator , - lappend stack $word - } else { - #no stack - so we don't expect to be in argprotect mode already. - if {[string match "-*" $word]} { - #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) - set operator_prev $operator - set operator "argprotect" - lappend stack $word - } else { - lappend stack $word - } - - } - } - incr w - } - - } - } ;#end while - - #process final word outside of loop - #assert $w == $wordcount - #trailing operators or last argument - if {!$finished_args} { - set word [lindex $args [expr {$w -1}]] - if {$operator eq "argprotect"} { - set operator $operator_prev - set operator_prev "" - - lappend stack $word - incr w - } else { - - - switch -- $word {.} { - if {![llength $stack]} { - #set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] - yieldto return [::p::internals::ref_to_object $_ID_] - error "assert: never gets here" - - } else { - #puts stdout "==== $stack" - #assert - whenever _ID_ changed in this proc - we have updated the $OID variable - yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] - error "assert: never gets here" - } - set operator . - - } {..} { - #trailing .. after chained call e.g >x . item 0 .. - #puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" - #set reduction [list 0 $_ID_ {*}$stack] - yieldto return [yield [list 0 $_ID_ {*}$stack]] - } {#} { - set unsupported 1 - } {,} { - set unsupported 1 - } {&} { - set unsupported 1 - } {@} { - set unsupported 1 - } {--} { - - #set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] - #puts stdout " -> -> -> about to call yield $reduction <- <- <-" - set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] - } - yieldto return $MAP - } {!} { - #error "untested branch" - set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] - #set OID [::pattern::get_oid $_ID_] - set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - if {$OID ne "null"} { - set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! - } else { - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] - } - lassign [dict get $MAP invocantdata] OID alias default_command object_command - set command $object_command - set stack [list "_exec_" $command] - set operator ! - } default { - if {$operator eq ""} { - #error "untested branch" - lassign [dict get $MAP invocantdata] OID alias default_command object_command - #set command ::p::${OID}::item - set command ::p::${OID}::$default_command - lappend stack $command - set operator , - - } - #do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. - lappend stack $word - } - if {$unsupported} { - set unsupported 0 - error "trailing '$word' not supported" - - } - - #if {$operator eq ","} { - # incr wordcount 2 - # set stack [linsert $stack end-1 . item] - #} - incr w - } - } - - - #final = 1 - #puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" - - return [list 1 $_ID_ {*}$stack] -} - - - -#trailing. directly after object -proc ::p::internals::ref_to_object {_ID_} { - set OID [lindex [dict get $_ID_ i this] 0 0] - upvar #0 ::p::${OID}::_meta::map MAP - lassign [dict get $MAP invocantdata] OID alias default_method object_command - set refname ::p::${OID}::_ref::__OBJECT - - array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces - - set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] - if {[list {read} $traceCmd] ni [trace info variable $refname]} { - #puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" - trace add variable $refname {read} $traceCmd - } - set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] - if {[list {array} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {array} $traceCmd - } - - set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] - if {[list {write} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {write} $traceCmd - } - - set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] - if {[list {unset} $traceCmd] ni [trace info variable $refname]} { - trace add variable $refname {unset} $traceCmd - } - return $refname -} - - -proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { - #if {[lindex $fullstack 0] eq "_exec_"} { - # #strip it. This instruction isn't relevant for a reference. - # set commandstack [lrange $fullstack 1 end] - #} else { - # set commandstack $fullstack - #} - #set argstack [lassign $commandstack command] - #set field [string map {> __OBJECT_} [namespace tail $command]] - - - - set reftail [namespace tail $refname] - set argstack [lassign [split $reftail +] field] - set field [string map {> __OBJECT_} [namespace tail $command]] - - #puts stderr "refname:'$refname' command: $command field:$field" - - - if {$OID ne "null"} { - upvar #0 ::p::${OID}::_meta::map MAP - } else { - #set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] - set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] - } - lassign [dict get $MAP invocantdata] OID alias default_method object_command - - - - if {$OID ne "null"} { - interp alias {} $refname {} $command $_ID_ {*}$argstack - } else { - interp alias {} $refname {} $command {*}$argstack - } - - - #set iflist [lindex $map 1 0] - set iflist [dict get $MAP interfaces level0] - #set iflist [dict get $MAP interfaces level0] - set field_is_property_like 0 - foreach IFID [lreverse $iflist] { - #tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. - if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { - set field_is_property_like 1 - #There is a setter or getter (but not necessarily an entry in the o_properties dict) - break - } - } - - - - - #whether field is a property or a method - remove any commandrefMisuse_TraceHandler - foreach tinfo [trace info variable $refname] { - #puts "-->removing traces on $refname: $tinfo" - if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { - trace remove variable $refname {*}$tinfo - } - } - - if {$field_is_property_like} { - #property reference - - - set this_invocantdata [lindex [dict get $_ID_ i this] 0] - lassign $this_invocantdata OID _alias _defaultmethod object_command - #get fully qualified varspace - - # - set propdict [$object_command .. GetPropertyInfo $field] - if {[dict exist $propdict $field]} { - set field_is_a_property 1 - set propinfo [dict get $propdict $field] - set varspace [dict get $propinfo varspace] - if {$varspace eq ""} { - set full_varspace ::p::${OID} - } else { - if {[::string match "::*" $varspace]} { - set full_varspace $varspace - } else { - set full_varspace ::p::${OID}::$varspace - } - } - } else { - set field_is_a_property 0 - #no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property - #this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) - set full_varspace ::p::${OID} - } - - - - - - #We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) - set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] - if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { - trace add variable ${full_varspace}::o_${field} {write} $Hndlr - } - set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] - if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { - trace add variable ${full_varspace}::o_${field} {unset} $Hndlr - } - - - #supply all data in easy-access form so that propref_trace_read is not doing any extra work. - set get_cmd ::p::${OID}::(GET)$field - set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] - - if {[list {read} $traceCmd] ni [trace info variable $refname]} { - set fieldvarname ${full_varspace}::o_${field} - - - #synch the refvar with the real var if it exists - #catch {set $refname [$refname]} - if {[array exists $fieldvarname]} { - if {![llength $argstack]} { - #unindexed reference - array set $refname [array get $fieldvarname] - #upvar $fieldvarname $refname - } else { - set s0 [lindex $argstack 0] - #refs to nonexistant array members common? (catch vs 'info exists') - if {[info exists ${fieldvarname}($s0)]} { - set $refname [set ${fieldvarname}($s0)] - } - } - } else { - #refs to uninitialised props actually should be *very* common. - #If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. - #Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. - - #set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! - - #puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" - - - if {![llength $argstack]} { - #catch {set $refname [set ::p::${OID}::o_$field]} - if {[info exists $fieldvarname]} { - set $refname [set $fieldvarname] - #upvar $fieldvarname $refname - } - } else { - if {[llength $argstack] == 1} { - #catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} - if {[info exists $fieldvarname]} { - set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] - } - - } else { - #catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} - if {[info exists $fieldvarname]} { - set $refname [lindex [set $fieldvarname] $argstack] - } - } - } - - #! what if someone has put a trace on ::errorInfo?? - #set ::errorInfo $errorInfo_prev - } - trace add variable $refname {read} $traceCmd - - set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] - trace add variable $refname {write} $traceCmd - - set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] - trace add variable $refname {unset} $traceCmd - - - set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] - # puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" - trace add variable $refname {array} $traceCmd - } - - } else { - #puts "$refname ====> adding refMisuse_traceHandler $alias $field" - #matching variable in order to detect attempted use as property and throw error - - #2018 - #Note that we are adding a trace on a variable (the refname) which does not exist. - #this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) - #we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added - ##array set $refname {} ;#empty array - # - the empty array would mean a slightly better error message when misusing a command ref as an array - #but this seems like a code complication for little benefit - #review - - trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] - } -} - - - -#trailing. after command/property -proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { - if {[lindex $fullstack 0] eq "_exec_"} { - #strip it. This instruction isn't relevant for a reference. - set commandstack [lrange $fullstack 1 end] - } else { - set commandstack $fullstack - } - set argstack [lassign $commandstack command] - set field [string map {> __OBJECT_} [namespace tail $command]] - - - #!todo? - # - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. - # - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. - - - #references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. - # - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. - - - set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] - - if {[llength [info commands $refname]]} { - #todo - review - what if the field changed to/from a property/method? - #probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs - return $refname - } - ::p::internals::create_or_update_reference $OID $_ID_ $refname $command - return $refname -} - - -namespace eval pp { - variable operators [list .. . -- - & @ # , !] - variable operators_notin_args "" - foreach op $operators { - append operators_notin_args "({$op} ni \$args) && " - } - set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands - #set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} -} -interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! - - - - - -# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. -#each map is a 2 element list of lists. -# form: {$commandinfo $interfaceinfo} -# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} - -#2018 -#each map is a dict. -#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} - - -#OID = Object ID (integer for now - could in future be a uuid) -proc ::p::predator2 {_ID_ args} { - #puts stderr "predator2: _ID_:'$_ID_' args:'$args'" - #set invocants [dict get $_ID_ i] - #set invocant_roles [dict keys $invocants] - - #For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. - #set this_role_members [dict get $invocants this] - #set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. - #lassign $this_invocant this_OID this_info_dict - - set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid - - - set cheat 1 ;# - #------- - #Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) - #(it should be functionally equivalent to remove this shortcut block) - if {$cheat} { - if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { - - set remaining_args [lassign $args dot method_or_prop] - - #how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? - set command ::p::${this_OID}::$method_or_prop - #REVIEW! - #e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') - #if {[llength $command] > 1} { - # error "methods with spaces not included in test suites - todo fix!" - #} - #Dont use {*}$command - (so we can support methods with spaces) - #if {![llength [info commands $command]]} {} - if {[namespace which $command] eq ""} { - if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { - #lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces - set command ::p::${this_OID}::(UNKNOWN) - #tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" - } - } else { - #tailcall {*}$command $_ID_ {*}$remaining_args - tailcall $command $_ID_ {*}$remaining_args - } - } - } - #------------ - - - if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { - return $_ID_ - } - - - #puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" - - - - #puts stderr "this_info_dict: $this_info_dict" - - - - - if {![llength $args]} { - #should return some sort of public info.. i.e probably not the ID which is an implementation detail - #return cmd - return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID - - #return a dict keyed on object command name - (suitable as use for a .. Create 'target') - #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped - #return [list $object_command [list -id $this_OID ]] - } elseif {[llength $args] == 1} { - #short-circuit the single index case for speed. - if {[lindex $args 0] ni {.. . -- - & @ # , !}} { - #lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method - lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method - - tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] - } elseif {[lindex $args 0] eq {--}} { - - #!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. - # - combined with using UUIDs for $OID, and a secured/removed metaface on the object - # - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) - # - this could effectively hide the object's namespaces,vars etc from the caller (?) - return [set ::p::${this_OID}::_meta::map] - } - } - - - - #upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) - #incr c - #set reduce ::p::reducer${this_OID}_$c - set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] - #puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" - coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args - - - set current_ID_ $_ID_ - - set final 0 - set result "" - while {$final == 0} { - #the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) - set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] - #puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" - #if {[string match *Destroy $command]} { - # puts stdout " calling Destroy reduction_args:'$reduction_args'" - #} - if {$final == 1} { - - if {[llength $command] == 1} { - if {$command eq "_exec_"} { - tailcall {*}$reduction_args - } - if {[llength [info commands $command]]} { - tailcall {*}$command $current_ID_ {*}$reduction_args - } - set cmdname [namespace tail $command] - set this_OID [lindex [dict get $current_ID_ i this] 0 0] - if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { - lset command 0 ::p::${this_OID}::(UNKNOWN) - tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" - } - - } else { - #e.g lindex {a b c} - tailcall {*}$command {*}$reduction_args - } - - - } else { - if {[lindex $command 0] eq "_exec_"} { - set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] - - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] - } else { - if {[llength $command] == 1} { - if {![llength [info commands $command]]} { - set cmdname [namespace tail $command] - set this_OID [lindex [dict get $current_ID_ i this] 0 0] - if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { - - lset command 0 ::p::${this_OID}::(UNKNOWN) - set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. - } else { - return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" - } - } else { - #set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] - set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] - - } - } else { - set result [uplevel 1 [list {*}$command {*}$reduction_args]] - } - - if {[llength [info commands $result]]} { - if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { - #looks like a pattern command - set current_ID_ [$result .. INVOCANTDATA] - - - #todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA - #if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { - # set current_ID_ $result_invocantdata - #} else { - # return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" - #} - } else { - #non-pattern command - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] - } - } else { - set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] - #!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) - - } - } - - } - } - error "Assert: Shouldn't get here (end of ::p::predator2)" - #return $result -} diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/promise-1.2.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/promise-1.2.0.tm deleted file mode 100644 index a4b82e45..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/promise-1.2.0.tm +++ /dev/null @@ -1,1311 +0,0 @@ -# Copyright (c) 2015-2023, Ashok P. Nadkarni -# All rights reserved. - -# Redistribution and use in source and binary forms, with or without -# modification, are permitted provided that the following conditions are -# met: - -# 1. Redistributions of source code must retain the above copyright -# notice, this list of conditions and the following disclaimer. - -# 2. Redistributions in binary form must reproduce the above copyright -# notice, this list of conditions and the following disclaimer in the -# documentation and/or other materials provided with the distribution. - -# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -# HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -package require Tcl 8.6- - -namespace eval promise { - proc version {} { return 1.2.0 } -} - -proc promise::lambda {params body args} { - # Creates an anonymous procedure and returns a command prefix for it. - # params - parameter definitions for the procedure - # body - body of the procedures - # args - additional arguments to be passed to the procedure when it - # is invoked - # - # This is just a convenience command since anonymous procedures are - # commonly useful with promises. The lambda package from tcllib - # is identical in function. - - return [list ::apply [list $params $body] {*}$args] -} - -catch {promise::Promise destroy} -oo::class create promise::Promise { - - # The promise state can be one of - # PENDING - Initial state where it has not yet been assigned a - # value or error - # FULFILLED - The promise has been assigned a value - # REJECTED - The promise has been assigned an error - # CHAINED - The promise is attached to another promise - variable _state - - # Stores data that is accessed through the setdata/getdata methods. - # The Promise class itself does not use this. - variable _clientdata - - # The promise value once it is fulfilled or rejected. In the latter - # case, it should be an the error message - variable _value - - # The error dictionary in case promise is rejected - variable _edict - - # Reactions to be notified when the promise is rejected. Each element - # in this list is a pair consisting of the fulfilment reaction - # and the rejection reaction. Either element of the pair could be - # empty signifying no reaction for that case. The list is populated - # via the then method. - variable _reactions - - # Reference counting to free up promises since Tcl does not have - # garbage collection for objects. Garbage collection via reference - # counting only takes place after at least one done/then reaction - # is placed on the event queue, not before. Else promises that - # are immediately resolved on construction would be freed right - # away before the application even gets a chance to call done/then. - variable _do_gc - variable _nrefs - - # If no reject reactions are registered, then the Tcl bgerror - # handler is invoked. But don't want to do this more than once - # so track it - variable _bgerror_done - - constructor {cmd} { - # Create a promise for the asynchronous operation to be initiated - # by $cmd. - # cmd - a command prefix that should initiate an asynchronous - # operation. - # The command prefix $cmd is passed an additional argument - the - # name of this Promise object. It should arrange for one of the - # object's settle methods [fulfill], [chain] or - # [reject] to be called when the operation completes. - - set _state PENDING - set _reactions [list ] - set _do_gc 0 - set _bgerror_done 0 - set _nrefs 0 - array set _clientdata {} - - # Errors in the construction command are returned via - # the standard mechanism of reject. - # - if {[catch { - # For some special cases, $cmd may be "" if the async operation - # is initiated outside the constructor. This is not a good - # thing because the error in the initiator will not be - # trapped via the standard promise error catching mechanism - # but that's the application's problem (actually pgeturl also - # uses this). - if {[llength $cmd]} { - uplevel #0 [linsert $cmd end [self]] - } - } msg edict]} { - my reject $msg $edict - } - } - - destructor { - # Destroys the object. - # - # This method should not be generally called directly as [Promise] - # objects are garbage collected either automatically or via the [ref] - # and [unref] methods. - } - - method state {} { - # Returns the current state of the promise. - # - # The promise state may be one of the values `PENDING`, - # `FULFILLED`, `REJECTED` or `CHAINED` - return $_state - } - - method getdata {key} { - # Returns data previously stored through the setdata method. - # key - key whose associated values is to be returned. - # An error will be raised if no value is associated with the key. - return $_clientdata($key) - } - - method setdata {key value} { - # Sets a value to be associated with a key. - # key - the lookup key - # value - the value to be associated with the key - # A promise internally maintains a dictionary whose values can - # be accessed with the [getdata] and [setdata] methods. This - # dictionary is not used by the Promise class itself but is meant - # to be used by promise library specializations or applications. - # Callers need to take care that keys used for a particular - # promise are sufficiently distinguishable so as to not clash. - # - # Returns the value stored with the key. - set _clientdata($key) $value - } - - method value {} { - # Returns the settled value for the promise. - # - # The returned value may be the fulfilled value or the rejected - # value depending on whether the associated operation was successfully - # completed or failed. - # - # An error is raised if the promise is not settled yet. - if {$_state ni {FULFILLED REJECTED}} { - error "Value is not set." - } - return $_value - } - - method ref {} { - # Increments the reference count for the object. - incr _nrefs - } - - method unref {} { - # Decrements the reference count for the object. - # - # The object may have been destroyed when the call returns. - incr _nrefs -1 - my GC - } - - method nrefs {} { - # Returns the current reference count. - # - # Use for debugging only! Note, internal references are not included. - return $_nrefs - } - - method GC {} { - if {$_nrefs <= 0 && $_do_gc && [llength $_reactions] == 0} { - my destroy - } - } - - method FulfillAttached {value} { - if {$_state ne "CHAINED"} { - return - } - set _value $value - set _state FULFILLED - my ScheduleReactions - return - } - - method RejectAttached {reason edict} { - if {$_state ne "CHAINED"} { - return - } - set _value $reason - set _edict $edict - set _state REJECTED - my ScheduleReactions - return - } - - # Method to invoke to fulfil a promise with a value or another promise. - method fulfill {value} { - # Fulfills the promise. - # value - the value with which the promise is fulfilled - # - # Returns `0` if promise had already been settled and `1` if - # it was fulfilled by the current call. - - #ruff - # If the promise has already been settled, the method has no effect. - if {$_state ne "PENDING"} { - return 0; # Already settled - } - - #ruff - # Otherwise, it is transitioned to the `FULFILLED` state with - # the value specified by $value. If there are any fulfillment - # reactions registered by the [Promise.done] or [Promise.then] methods, they - # are scheduled to be run. - set _value $value - set _state FULFILLED - my ScheduleReactions - return 1 - } - - # Method to invoke to fulfil a promise with a value or another promise. - method chain {promise} { - # Chains the promise to another promise. - # promise - the [Promise] object to which this promise is to - # be chained - # - # Returns `0` if promise had already been settled and `1` otherwise. - - #ruff - # If the promise on which this method is called - # has already been settled, the method has no effect. - if {$_state ne "PENDING"} { - return 0; - } - - #ruff - # Otherwise, it is chained to $promise so that it reflects that - # other promise's state. - if {[catch { - $promise done [namespace code {my FulfillAttached}] [namespace code {my RejectAttached}] - } msg edict]} { - my reject $msg $edict - } else { - set _state CHAINED - } - - return 1 - } - - method reject {reason {edict {}}} { - # Rejects the promise. - # reason - a message string describing the reason for the rejection. - # edict - a Tcl error dictionary - # - # The $reason and $edict values are passed on to the rejection - # reactions. By convention, these should be of the form returned - # by the `catch` or `try` commands in case of errors. - # - # Returns `0` if promise had already been settled and `1` if - # it was rejected by the current call. - - #ruff - # If the promise has already been settled, the method has no effect. - if {$_state ne "PENDING"} { - return 0; # Already settled - } - - #ruff - # Otherwise, it is transitioned to the `REJECTED` state. If - # there are any reject reactions registered by the [Promise.done] or - # [Promise.then] methods, they are scheduled to be run. - - set _value $reason - #ruff - # If $edict is not specified, or specified as an empty string, - # a suitable error dictionary is constructed in its place - # to be passed to the reaction. - if {$edict eq ""} { - catch {throw {PROMISE REJECTED} $reason} - edict - } - set _edict $edict - set _state REJECTED - my ScheduleReactions - return 1 - } - - # Internal method to queue all registered reactions based on - # whether the promise is succesfully fulfilled or not - method ScheduleReactions {} { - if {$_state ni {FULFILLED REJECTED} || [llength $_reactions] == 0 } { - # Promise is not settled or no reactions registered - return - } - - # Note on garbage collection: garbage collection is to be enabled if - # at least one FULFILLED or REJECTED reaction is registered. - # Also if the promise is REJECTED but no rejection handlers are run - # we also schedule a background error. - # In all cases, CLEANUP reactions do not count. - foreach reaction $_reactions { - foreach type {FULFILLED REJECTED} { - if {[dict exists $reaction $type]} { - set _do_gc 1 - if {$type eq $_state} { - set cmd [dict get $reaction $type] - if {[llength $cmd]} { - if {$type eq "FULFILLED"} { - lappend cmd $_value - } else { - lappend cmd $_value $_edict - } - set ran_reaction($type) 1 - # Enqueue the reaction via the event loop - after 0 [list after idle $cmd] - } - } - } - } - if {[dict exists $reaction CLEANUP]} { - set cmd [dict get $reaction CLEANUP] - if {[llength $cmd]} { - # Enqueue the cleaner via the event loop passing the - # *state* as well as the value - if {$_state eq "REJECTED"} { - lappend cmd $_state $_value $_edict - } else { - lappend cmd $_state $_value - } - after 0 [list after idle $cmd] - # Note we do not set _do_gc if we only run cleaners - } - } - } - set _reactions [list ] - - # Check for need to background error (see comments above) - if {$_state eq "REJECTED" && $_do_gc && ! [info exists ran_reaction(REJECTED)] && ! $_bgerror_done} { - # TBD - should we also check _nrefs before backgrounding error? - - # Wrap in catch in case $_edict does not follow error conventions - # or is not even a dictionary - if {[catch { - dict get $_edict -level - dict get $_edict -code - }]} { - catch {throw {PROMISE REJECT} $_value} - edict - } else { - set edict $_edict - } - # TBD - how exactly is level to be handled? - # If -level is not 0, bgerror barfs because it treates - # it as TCL_RETURN no matter was -code is - dict set edict -level 0 - after idle [interp bgerror {}] [list $_value $edict] - set _bgerror_done 1 - } - - my GC - return - } - - method RegisterReactions {args} { - # Registers the specified reactions. - # args - dictionary keyed by `CLEANUP`, `FULFILLED`, `REJECTED` - # with values being the corresponding reaction callback - - lappend _reactions $args - my ScheduleReactions - return - } - - method done {{on_fulfill {}} {on_reject {}}} { - # Registers reactions to be run when the promise is settled. - # on_fulfill - command prefix for the reaction to run - # if the promise is fulfilled. - # reaction is registered. - # on_reject - command prefix for the reaction to run - # if the promise is rejected. - # Reactions are called with an additional argument which is - # the value with which the promise was settled. - # - # The command may be called multiple times to register multiple - # reactions to be run at promise settlement. If the promise was - # already settled at the time the call was made, the reactions - # are invoked immediately. In all cases, reactions are not called - # directly, but are invoked by scheduling through the event loop. - # - # The method triggers garbage collection of the object if the - # promise has been settled and any registered reactions have been - # scheduled. Applications can hold on to the object through - # appropriate use of the [ref] and [unref] methods. - # - # Note that both $on_fulfill and $on_reject may be specified - # as empty strings if no further action needs to be taken on - # settlement of the promise. If the promise is rejected, and - # no rejection reactions are registered, the error is reported - # via the Tcl `interp bgerror` facility. - - # TBD - as per the Promise/A+ spec, errors in done should generate - # a background error (unlike then). - - my RegisterReactions FULFILLED $on_fulfill REJECTED $on_reject - - #ruff - # The method does not return a value. - return - } - - method then {on_fulfill {on_reject {}}} { - # Registers reactions to be run when the promise is settled - # and returns a new [Promise] object that will be settled by the - # reactions. - # on_fulfill - command prefix for the reaction to run - # if the promise is fulfilled. If an empty string, no fulfill - # reaction is registered. - # on_reject - command prefix for the reaction to run - # if the promise is rejected. If unspecified or an empty string, - # no reject reaction is registered. - # Both reactions are passed the value with which the promise was settled. - # The reject reaction is passed an additional argument which is - # the error dictionary. - # - # The command may be called multiple times to register multiple - # reactions to be run at promise settlement. If the promise was - # already settled at the time the call was made, the reactions - # are invoked immediately. In all cases, reactions are not called - # directly, but are invoked by scheduling through the event loop. - # - # If the reaction that is invoked runs without error, its return - # value fulfills the new promise returned by the `then` method. - # If it raises an exception, the new promise will be rejected - # with the error message and dictionary from the exception. - # - # Alternatively, the reactions can explicitly invoke commands - # [then_fulfill], [then_reject] or [then_chain] to - # resolve the returned promise. In this case, the return value - # (including exceptions) from the reactions are ignored. - # - # If `on_fulfill` (or `on_reject`) is an empty string (or unspecified), - # the new promise is created and fulfilled (or rejected) with - # the same value that would have been passed in to the reactions. - # - # The method triggers garbage collection of the object if the - # promise has been settled and registered reactions have been - # scheduled. Applications can hold on to the object through - # appropriate use of the [ref] and [unref] methods. - # - # Returns a new promise that is settled by the registered reactions. - - set then_promise [[self class] new ""] - my RegisterReactions \ - FULFILLED [list ::promise::_then_reaction $then_promise FULFILLED $on_fulfill] \ - REJECTED [list ::promise::_then_reaction $then_promise REJECTED $on_reject] - return $then_promise - } - - # This could be a forward, but then we cannot document it via ruff! - method catch {on_reject} { - # Registers reactions to be run when the promise is rejected. - # on_reject - command prefix for the reaction - # reaction to run if the promise is rejected. If unspecified - # or an empty string, no reject reaction is registered. The - # reaction is called with an additional argument which is the - # value with which the promise was settled. - # This method is just a wrapper around [Promise.then] with the - # `on_fulfill` parameter defaulting to an empty string. See - # the description of that method for details. - return [my then "" $on_reject] - } - - method cleanup {cleaner} { - # Registers a reaction to be executed for running cleanup - # code when the promise is settled. - # cleaner - command prefix to run on settlement - # This method is intended to run a clean up script - # when a promise is settled. Its primary use is to avoid duplication - # of code in the `then` and `catch` handlers for a promise. - # It may also be called multiple times - # to clean up intermediate steps when promises are chained. - # - # The method returns a new promise that will be settled - # as per the following rules. - # - if the cleaner runs without errors, the returned promise - # will reflect the settlement of the promise on which this - # method is called. - # - if the cleaner raises an exception, the returned promise - # is rejected with a value consisting of the error message - # and dictionary pair. - # - # Returns a new promise that is settled based on the cleaner - set cleaner_promise [[self class] new ""] - my RegisterReactions CLEANUP [list ::promise::_cleanup_reaction $cleaner_promise $cleaner] - return $cleaner_promise - } -} - -proc promise::_then_reaction {target_promise status cmd value {edict {}}} { - # Run the specified command and fulfill/reject the target promise - # accordingly. If the command is empty, the passed-in value is passed - # on to the target promise. - - # IMPORTANT!!!! - # MUST BE CALLED FROM EVENT LOOP AT so info level must be 1. Else - # promise::then_fulfill/then_reject/then_chain will not work - # Also, Do NOT change the param name target_promise without changing - # those procs. - # Oh what a hack to get around lack of closures. Alternative would have - # been to pass an additional parameter (target_promise) - # to the application code but then that script would have had to - # carry that around. - - if {[info level] != 1} { - error "Internal error: _then_reaction not at level 1" - } - - if {[llength $cmd] == 0} { - switch -exact -- $status { - FULFILLED { $target_promise fulfill $value } - REJECTED { $target_promise reject $value $edict} - CHAINED - - PENDING - - default { - $target_promise reject "Internal error: invalid status $state" - } - } - } else { - # Invoke the real reaction code and fulfill/reject the target promise. - # Note the reaction code may have called one of the promise::then_* - # commands itself and reactions run resulting in the object being - # freed. Hence resolve using the safe* variants - # TBD - ideally we would like to execute at global level. However - # the then_* commands retrieve target_promise from level 1 (here) - # which they cannot if uplevel #0 is done. So directly invoke. - if {$status eq "REJECTED"} { - lappend cmd $value $edict - } else { - lappend cmd $value - } - if {[catch $cmd reaction_value reaction_edict]} { - safe_reject $target_promise $reaction_value $reaction_edict - } else { - safe_fulfill $target_promise $reaction_value - } - } - return -} - -proc promise::_cleanup_reaction {target_promise cleaner state value {edict {}}} { - # Run the specified cleaner and fulfill/reject the target promise - # accordingly. If the cleaner executes without error, the original - # value and state is passed on. If the cleaner executes with error - # the promise is rejected. - - if {[llength $cleaner] == 0} { - switch -exact -- $state { - FULFILLED { $target_promise fulfill $value } - REJECTED { $target_promise reject $value $edict } - CHAINED - - PENDING - - default { - $target_promise reject "Internal error: invalid state $state" - } - } - } else { - if {[catch {uplevel #0 $cleaner} err edict]} { - # Cleaner failed. Reject the target promise - $target_promise reject $err $edict - } else { - # Cleaner completed without errors, pass on the original value - if {$state eq "FULFILLED"} { - $target_promise fulfill $value - } else { - $target_promise reject $value $edict - } - } - } - return -} - -proc promise::then_fulfill {value} { - # Fulfills the promise returned by a [Promise.then] method call from - # within its reaction. - # value - the value with which to fulfill the promise - # - # The [Promise.then] method is a mechanism to chain asynchronous - # reactions by registering them on a promise. It returns a new - # promise which is settled by the return value from the reaction, - # or by the reaction calling one of three commands - `then_fulfill`, - # [then_reject] or [then_chain]. Calling `then_fulfill` fulfills - # the promise returned by the `then` method that queued the currently - # running reaction. - # - # It is an error to call this command from outside a reaction - # that was queued via the [Promise.then] method on a promise. - - # TBD - what if someone calls this from within a uplevel #0 ? The - # upvar will be all wrong - upvar #1 target_promise target_promise - if {![info exists target_promise]} { - set msg "promise::then_fulfill called in invalid context." - throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg - } - $target_promise fulfill $value -} - -proc promise::then_chain {promise} { - # Chains the promise returned by a [Promise.then] method call to - # another promise. - # promise - the promise to which the promise returned by [Promise.then] is - # to be chained - # - # The [Promise.then] method is a mechanism to chain asynchronous - # reactions by registering them on a promise. It returns a new - # promise which is settled by the return value from the reaction, - # or by the reaction calling one of three commands - [then_fulfill], - # `then_reject` or [then_chain]. Calling `then_chain` chains - # the promise returned by the `then` method that queued the currently - # running reaction to $promise so that the former will be settled - # based on the latter. - # - # It is an error to call this command from outside a reaction - # that was queued via the [Promise.then] method on a promise. - upvar #1 target_promise target_promise - if {![info exists target_promise]} { - set msg "promise::then_chain called in invalid context." - throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg - } - $target_promise chain $promise -} - -proc promise::then_reject {reason edict} { - # Rejects the promise returned by a [Promise.then] method call from - # within its reaction. - # reason - a message string describing the reason for the rejection. - # edict - a Tcl error dictionary - # The [Promise.then] method is a mechanism to chain asynchronous - # reactions by registering them on a promise. It returns a new - # promise which is settled by the return value from the reaction, - # or by the reaction calling one of three commands - [then_fulfill], - # `then_reject` or [then_chain]. Calling `then_reject` rejects - # the promise returned by the `then` method that queued the currently - # running reaction. - # - # It is an error to call this command from outside a reaction - # that was queued via the [Promise.then] method on a promise. - upvar #1 target_promise target_promise - if {![info exists target_promise]} { - set msg "promise::then_reject called in invalid context." - throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg - } - $target_promise reject $reason $edict -} - -proc promise::all {promises} { - # Returns a promise that fulfills or rejects when all promises - # in the $promises argument have fulfilled or any one has rejected. - # promises - a list of Promise objects - # If any of $promises rejects, then the promise returned by the - # command will reject with the same value. Otherwise, the promise - # will fulfill when all promises have fulfilled. - # The resolved value will be a list of the resolved - # values of the contained promises. - - set all_promise [Promise new [lambda {promises prom} { - set npromises [llength $promises] - if {$npromises == 0} { - $prom fulfill {} - return - } - - # Ask each promise to update us when resolved. - foreach promise $promises { - $promise done \ - [list ::promise::_all_helper $prom $promise FULFILLED] \ - [list ::promise::_all_helper $prom $promise REJECTED] - } - - # We keep track of state with a dictionary that will be - # stored in $prom with the following keys: - # PROMISES - the list of promises in the order passed - # PENDING_COUNT - count of unresolved promises - # RESULTS - dictionary keyed by promise and containing resolved value - set all_state [list PROMISES $promises PENDING_COUNT $npromises RESULTS {}] - - $prom setdata ALLPROMISES $all_state - } $promises]] - - return $all_promise -} - -proc promise::all* args { - # Returns a promise that fulfills or rejects when all promises - # in the $args argument have fulfilled or any one has rejected. - # args - list of Promise objects - # This command is identical to the all command except that it takes - # multiple arguments, each of which is a Promise object. See [all] - # for a description. - return [all $args] -} - -# Callback for promise::all. -# all_promise - the "master" promise returned by the all call. -# done_promise - the promise whose callback is being serviced. -# resolution - whether the current promise was resolved with "FULFILLED" -# or "REJECTED" -# value - the value of the currently fulfilled promise or error description -# in case rejected -# edict - error dictionary (if promise was rejected) -proc promise::_all_helper {all_promise done_promise resolution value {edict {}}} { - if {![info object isa object $all_promise]} { - # The object has been deleted. Naught to do - return - } - if {[$all_promise state] ne "PENDING"} { - # Already settled. This can happen when a tracked promise is - # rejected and another tracked promise gets settled afterwards. - return - } - if {$resolution eq "REJECTED"} { - # This promise failed. Immediately reject the master promise - # TBD - can we somehow indicate which promise failed ? - $all_promise reject $value $edict - return - } - - # Update the state of the resolved tracked promise - set all_state [$all_promise getdata ALLPROMISES] - dict set all_state RESULTS $done_promise $value - dict incr all_state PENDING_COUNT -1 - $all_promise setdata ALLPROMISES $all_state - - # If all promises resolved, resolve the all promise - if {[dict get $all_state PENDING_COUNT] == 0} { - set values {} - foreach prom [dict get $all_state PROMISES] { - lappend values [dict get $all_state RESULTS $prom] - } - $all_promise fulfill $values - } - return -} - -proc promise::race {promises} { - # Returns a promise that fulfills or rejects when any promise - # in the $promises argument is fulfilled or rejected. - # promises - a list of Promise objects - # The returned promise will fulfill and reject with the same value - # as the first promise in $promises that fulfills or rejects. - set race_promise [Promise new [lambda {promises prom} { - if {[llength $promises] == 0} { - catch {throw {PROMISE RACE EMPTYSET} "No promises specified."} reason edict - $prom reject $reason $edict - return - } - # Use safe_*, do not directly call methods since $prom may be - # gc'ed once settled - foreach promise $promises { - $promise done [list ::promise::safe_fulfill $prom ] [list ::promise::safe_reject $prom] - } - } $promises]] - - return $race_promise -} - -proc promise::race* {args} { - # Returns a promise that fulfills or rejects when any promise - # in the passed arguments is fulfilled or rejected. - # args - list of Promise objects - # This command is identical to the `race` command except that it takes - # multiple arguments, each of which is a Promise object. See [race] - # for a description. - return [race $args] -} - -proc promise::await {prom} { - # Waits for a promise to be settled and returns its resolved value. - # prom - the promise that is to be waited on - # This command may only be used from within a procedure constructed - # with the [async] command or any code invoked from it. - # - # Returns the resolved value of $prom if it is fulfilled or raises an error - # if it is rejected. - set coro [info coroutine] - if {$coro eq ""} { - throw {PROMISE AWAIT NOTCORO} "await called from outside a coroutine" - } - $prom done [list $coro success] [list $coro fail] - lassign [yieldto return -level 0] status val ropts - if {$status eq "success"} { - return $val - } else { - return -options $ropts $val - } -} - -proc promise::async {name paramdefs body} { - # Defines an procedure that will run a script asynchronously as a coroutine. - # name - name of the procedure - # paramdefs - the parameter definitions to the procedure in the same - # form as passed to the standard `proc` command - # body - the script to be executed - # - # When the defined procedure $name is called, it runs the supplied $body - # within a new coroutine. The return value from the $name procedure call - # will be a promise that will be fulfilled when the coroutine completes - # normally or rejected if it completes with an error. - # - # Note that the passed $body argument is not the body of the - # the procedure $name. Rather it is run as an anonymous procedure in - # the coroutine but in the same namespace context as $name. Thus the - # caller or the $body script must not make any assumptions about - # relative stack levels, use of `uplevel` etc. - # - # The primary purpose of this command is to make it easy, in - # conjunction with the [await] command, to wrap a sequence of asynchronous - # operations as a single computational unit. - # - # Returns a promise that will be settled with the result of the script. - if {![string equal -length 2 "$name" "::"]} { - set ns [uplevel 1 namespace current] - set name ${ns}::$name - } else { - set ns :: - } - set tmpl { - proc %NAME% {%PARAMDEFS%} { - set p [promise::Promise new [promise::lambda {real_args prom} { - coroutine ::promise::async#[info cmdcount] {*}[promise::lambda {p args} { - upvar #1 _current_async_promise current_p - set current_p $p - set status [catch [list apply [list {%PARAMDEFS%} {%BODY%} %NS%] {*}$args] res ropts] - if {$status == 0} { - $p fulfill $res - } else { - $p reject $res $ropts - } - } $prom {*}$real_args] - } [lrange [info level 0] 1 end]]] - return $p - } - } - eval [string map [list %NAME% $name \ - %PARAMDEFS% $paramdefs \ - %BODY% $body \ - %NS% $ns] $tmpl] -} - -proc promise::async_fulfill {val} { - # Fulfills a promise for an async procedure with the specified value. - # val - the value with which to fulfill the promise - # This command must only be called with the context of an [async] - # procedure. - # - # Returns an empty string. - upvar #1 _current_async_promise current_p - if {![info exists current_p]} { - error "async_fulfill called from outside an async context." - } - $current_p fulfill $val - return -} - -proc promise::async_reject {val {edict {}}} { - # Rejects a promise for an async procedure with the specified value. - # val - the value with which to reject the promise - # edict - error dictionary for rejection - # This command must only be called with the context of an [async] - # procedure. - # - # Returns an empty string. - upvar #1 _current_async_promise current_p - if {![info exists current_p]} { - error "async_reject called from outside an async context." - } - $current_p reject $val $edict - return -} - -proc promise::async_chain {prom} { - # Chains a promise for an async procedure to the specified promise. - # prom - the promise to which the async promise is to be linked. - # This command must only be called with the context of an [async] - # procedure. - # - # Returns an empty string. - upvar #1 _current_async_promise current_p - if {![info exists current_p]} { - error "async_chain called from outside an async context." - } - $current_p chain $prom - return -} - -proc promise::pfulfilled {value} { - # Returns a new promise that is already fulfilled with the specified value. - # value - the value with which to fulfill the created promise - return [Promise new [lambda {value prom} { - $prom fulfill $value - } $value]] -} - -proc promise::prejected {value {edict {}}} { - # Returns a new promise that is already rejected. - # value - the value with which to reject the promise - # edict - error dictionary for rejection - # By convention, $value should be of the format returned by - # [Promise.reject]. - return [Promise new [lambda {value edict prom} { - $prom reject $value $edict - } $value $edict]] -} - -proc promise::eventloop {prom} { - # Waits in the eventloop until the specified promise is settled. - # prom - the promise to be waited on - # The command enters the event loop in similar fashion to the - # Tcl `vwait` command except that instead of waiting on a variable - # the command waits for the specified promise to be settled. As such - # it has the same caveats as the vwait command in terms of care - # being taken in nested calls etc. - # - # The primary use of the command is at the top level of a script - # to wait for one or more promise based tasks to be completed. Again, - # similar to the vwait forever idiom. - # - # - # Returns the resolved value of $prom if it is fulfilled or raises an error - # if it is rejected. - - set varname [namespace current]::_pwait_[info cmdcount] - $prom done \ - [lambda {varname result} { - set $varname [list success $result] - } $varname] \ - [lambda {varname error ropts} { - set $varname [list fail $error $ropts] - } $varname] - vwait $varname - lassign [set $varname] status result ropts - if {$status eq "success"} { - return $result - } else { - return -options $ropts $result - } -} - -proc promise::pgeturl {url args} { - # Returns a promise that will be fulfilled when the URL is fetched. - # url - the URL to fetch - # args - arguments to pass to the `http::geturl` command - # This command invokes the asynchronous form of the `http::geturl` command - # of the `http` package. If the operation completes with a status of - # `ok`, the returned promise is fulfilled with the contents of the - # http state array (see the documentation of `http::geturl`). If the - # the status is anything else, the promise is rejected with - # the `reason` parameter to the reaction containing the error message - # and the `edict` parameter containing the Tcl error dictionary - # with an additional key `http_state`, containing the - # contents of the http state array. - - uplevel #0 {package require http} - proc pgeturl {url args} { - set prom [Promise new [lambda {http_args prom} { - http::geturl {*}$http_args -command [promise::lambda {prom tok} { - upvar #0 $tok http_state - if {$http_state(status) eq "ok"} { - $prom fulfill [array get http_state] - } else { - if {[info exists http_state(error)]} { - set msg [lindex $http_state(error) 0] - } - if {![info exists msg] || $msg eq ""} { - set msg "Error retrieving URL." - } - catch {throw {PROMISE PGETURL} $msg} msg edict - dict set edict http_state [array get http_state] - $prom reject $msg $edict - } - http::cleanup $tok - } $prom] - } [linsert $args 0 $url]]] - return $prom - } - tailcall pgeturl $url {*}$args -} - -proc promise::ptimer {millisecs {value "Timer expired."}} { - # Returns a promise that will be fulfilled when the specified time has - # elapsed. - # millisecs - time interval in milliseconds - # value - the value with which the promise is to be fulfilled - # In case of errors (e.g. if $milliseconds is not an integer), the - # promise is rejected with the `reason` parameter set to an error - # message and the `edict` parameter set to a Tcl error dictionary. - # - # Also see [ptimeout] which is similar but rejects the promise instead - # of fulfilling it. - - return [Promise new [lambda {millisecs value prom} { - if {![string is integer -strict $millisecs]} { - # We don't allow "idle", "cancel" etc. as an argument to after - throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"." - } - after $millisecs [list promise::safe_fulfill $prom $value] - } $millisecs $value]] -} - -proc promise::ptimeout {millisecs {value "Operation timed out."}} { - # Returns a promise that will be rejected when the specified time has - # elapsed. - # millisecs - time interval in milliseconds - # value - the value with which the promise is to be rejected - # In case of errors (e.g. if $milliseconds is not an integer), the - # promise is rejected with the `reason` parameter set to $value - # and the `edict` parameter set to a Tcl error dictionary. - # - # Also see [ptimer] which is similar but fulfills the promise instead - # of rejecting it. - - return [Promise new [lambda {millisecs value prom} { - if {![string is integer -strict $millisecs]} { - # We don't want to accept "idle", "cancel" etc. for after - throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"." - } - after $millisecs [::promise::lambda {prom msg} { - catch {throw {PROMISE TIMER EXPIRED} $msg} msg edict - ::promise::safe_reject $prom $msg $edict - } $prom $value] - } $millisecs $value]] -} - -proc promise::pconnect {args} { - # Returns a promise that will be fulfilled when the socket connection - # is completed. - # args - arguments to be passed to the Tcl `socket` command - # This is a wrapper for the async version of the Tcl `socket` command. - # If the connection completes, the promise is fulfilled with the - # socket handle. - # In case of errors (e.g. if the address cannot be fulfilled), the - # promise is rejected with the `reason` parameter containing the - # error message and the `edict` parameter containing the Tcl error - # dictionary. - # - return [Promise new [lambda {so_args prom} { - set so [socket -async {*}$so_args] - fileevent $so writable [promise::lambda {prom so} { - fileevent $so writable {} - set err [chan configure $so -error] - if {$err eq ""} { - $prom fulfill $so - } else { - catch {throw {PROMISE PCONNECT FAIL} $err} err edict - $prom reject $err $edict - } - } $prom $so] - } $args]] -} - -proc promise::_read_channel {prom chan data} { - set newdata [read $chan] - if {[string length $newdata] || ![eof $chan]} { - append data $newdata - fileevent $chan readable [list [namespace current]::_read_channel $prom $chan $data] - return - } - - # EOF - set code [catch { - # Need to make the channel blocking else no error is returned - # on the close - fileevent $chan readable {} - fconfigure $chan -blocking 1 - close $chan - } result edict] - if {$code} { - safe_reject $prom $result $edict - } else { - safe_fulfill $prom $data - } -} - -proc promise::pexec {args} { - # Runs an external program and returns a promise for its output. - # args - program and its arguments as passed to the Tcl `open` call - # for creating pipes - # If the program runs without errors, the promise is fulfilled by its - # standard output content. Otherwise - # promise is rejected. - # - # Returns a promise that will be settled by the result of the program - return [Promise new [lambda {open_args prom} { - set chan [open |$open_args r] - fconfigure $chan -blocking 0 - fileevent $chan readable [list promise::_read_channel $prom $chan ""] - } $args]] -} - -proc promise::safe_fulfill {prom value} { - # Fulfills the specified promise. - # prom - the [Promise] object to be fulfilled - # value - the fulfillment value - # This is a convenience command that checks if $prom still exists - # and if so fulfills it with $value. - # - # Returns 0 if the promise does not exist any more, else the return - # value from its [fulfill][Promise.fulfill] method. - if {![info object isa object $prom]} { - # The object has been deleted. Naught to do - return 0 - } - return [$prom fulfill $value] -} - -proc promise::safe_reject {prom value {edict {}}} { - # Rejects the specified promise. - # prom - the [Promise] object to be fulfilled - # value - see [Promise.reject] - # edict - see [Promise.reject] - # This is a convenience command that checks if $prom still exists - # and if so rejects it with the specified arguments. - # - # Returns 0 if the promise does not exist any more, else the return - # value from its [reject][Promise.reject] method. - if {![info object isa object $prom]} { - # The object has been deleted. Naught to do - return - } - $prom reject $value $edict -} - -proc promise::ptask {script} { - # Creates a new Tcl thread to run the specified script and returns - # a promise for the script results. - # script - script to run in the thread - # Returns a promise that will be settled by the result of the script - # - # The `ptask` command runs the specified script in a new Tcl - # thread. The promise returned from this command will be fulfilled - # with the result of the script if it completes - # successfully. Otherwise, the promise will be rejected with an - # with the `reason` parameter containing the error message - # and the `edict` parameter containing the Tcl error dictionary - # from the script failure. - # - # Note that $script is a standalone script in that it is executed - # in a new thread with a virgin Tcl interpreter. Any packages used - # by $script have to be explicitly loaded, variables defined in the - # the current interpreter will not be available in $script and so on. - # - # The command requires the Thread package to be loaded. - - uplevel #0 package require Thread - proc [namespace current]::ptask script { - return [Promise new [lambda {script prom} { - set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] { - set retcode [catch {%SCRIPT%} result edict] - if {$retcode == 0 || $retcode == 2} { - # ok or return - set response [list ::promise::safe_fulfill %PROM% $result] - } else { - set response [list ::promise::safe_reject %PROM% $result $edict] - } - thread::send -async %TID% $response - }] - thread::create $thread_script - } $script]] - } - tailcall [namespace current]::ptask $script -} - -proc promise::pworker {tpool script} { - # Runs a script in a worker thread from a thread pool and - # returns a promise for the same. - # tpool - thread pool identifier - # script - script to run in the worker thread - # Returns a promise that will be settled by the result of the script - # - # The Thread package allows creation of a thread pool with the - # `tpool create` command. The `pworker` command runs the specified - # script in a worker thread from a thread pool. The promise - # returned from this command will be fulfilled with the result of - # the script if it completes successfully. - # Otherwise, the promise will be rejected with an - # with the `reason` parameter containing the error message - # and the `edict` parameter containing the Tcl error dictionary - # from the script failure. - # - # Note that $script is a standalone script in that it is executed - # in a new thread with a virgin Tcl interpreter. Any packages used - # by $script have to be explicitly loaded, variables defined in the - # the current interpreter will not be available in $script and so on. - - # No need for package require Thread since if tpool is passed to - # us, Thread must already be loaded - return [Promise new [lambda {tpool script prom} { - set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] { - set retcode [catch {%SCRIPT%} result edict] - if {$retcode == 0 || $retcode == 2} { - set response [list ::promise::safe_fulfill %PROM% $result] - } else { - set response [list ::promise::safe_reject %PROM% $result $edict] - } - thread::send -async %TID% $response - }] - tpool::post -detached -nowait $tpool $thread_script - } $tpool $script]] -} - -if {0} { - package require http - proc checkurl {url} { - set prom [promise::Promise new [promise::lambda {url prom} { - http::geturl $url -method HEAD -command [promise::lambda {prom tok} { - upvar #0 $tok http_state - $prom fulfill [list $http_state(url) $http_state(status)] - ::http::cleanup $tok - } $prom] - } $url]] - return $prom - } - - proc checkurls {urls} { - return [promise::all [lmap url $urls {checkurl $url}]] - } - - [promise::all [ - list [ - promise::ptask {expr 1+1} - ] [ - promise::ptask {expr 2+2} - ] - ]] done [promise::lambda val {puts [tcl::mathop::* {*}$val]}] -} - -package provide promise [promise::version] - -if {[info exists ::argv0] && - [file tail [info script]] eq [file tail $::argv0]} { - set filename [file tail [info script]] - if {[llength $::argv] == 0} { - puts "Usage: [file tail [info nameofexecutable]] $::argv0 dist|install|tm|version" - exit 1 - } - switch -glob -- [lindex $::argv 0] { - ver* { puts [promise::version] } - tm - - dist* { - if {[file extension $filename] ne ".tm"} { - set dir [file join [file dirname [info script]] .. build] - file mkdir $dir - file copy -force [info script] [file join $dir [file rootname $filename]-[promise::version].tm] - } else { - error "Cannot create distribution from a .tm file" - } - } - install { - # Install in first native file system that exists on search path - foreach path [tcl::tm::path list] { - if {[lindex [file system $path] 0] eq "native"} { - set dir $path - if {[file isdirectory $path]} { - break - } - # Else keep looking - } - } - if {![file exists $dir]} { - file mkdir $dir - } - if {[file extension $filename] eq ".tm"} { - # We already are a .tm with version number - set target $filename - } else { - set target [file rootname $filename]-[promise::version].tm - } - file copy -force [info script] [file join $dir $target] - } - default { - puts stderr "Unknown option/command \"[lindex $::argv 0]\"" - exit 1 - } - } -} diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm deleted file mode 100644 index 55408253..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm +++ /dev/null @@ -1,8388 +0,0 @@ -#Punk - where radical modification is a craft and anti-patterns are another exploratory tool for the Pattern Punk. -#Built on Tcl of course - because it's the most powerful piece of under-appreciated and alternate-thinking engineering you can plug into. - - -namespace eval punk { - proc lazyload {pkg} { - package require zzzload - if {[package provide $pkg] eq ""} { - zzzload::pkg_require $pkg - } - } - #lazyload twapi ? - - catch {package require vfs} ;#attempt load now so we can use faster 'package provide' to test existence later - - variable can_exec_windowsapp - set can_exec_windowsapp unknown ;#don't spend a potential X00ms testing until needed - variable windowsappdir - set windowsappdir "" - variable cmdexedir - set cmdexedir "" - - proc sync_package_paths_script {} { - #the tcl::tm namespace doesn't exist until one of the tcl::tm commands - #is run. (they are loaded via ::auto_index triggering load of tm.tcl) - #we call tcl::tm::list to trigger the initial set of tm paths before - #we can override it, otherwise our changes will be lost - #REVIEW - won't work on safebase interp where paths are mapped to {$p(:x:)} etc - return "\ - apply {{ap tmlist} { - set ::auto_path \$ap - tcl::tm::list - set ::tcl::tm::paths \$tmlist - }} {$::auto_path} {[tcl::tm::list]} - " - } - - proc rehash {{refresh 0}} { - global auto_execs - if {!$refresh} { - unset -nocomplain auto_execs - } else { - set names [array names auto_execs] - unset -nocomplain auto_execs - foreach nm $names { - auto_execok_windows $nm - } - } - return - } - - - proc ::punk::auto_execok_original name [info body ::auto_execok] - variable better_autoexec - - #set better_autoexec 0 ;#use this var via better_autoexec only - #proc ::punk::auto_execok_windows name { - # ::punk::auto_execok_original $name - #} - - set better_autoexec 1 - proc ::punk::auto_execok_windows name { - ::punk::auto_execok_better $name - } - - set has_commandstack [expr {![catch {package require commandstack}]}] - if {$has_commandstack} { - if {[catch { - package require punk::packagepreference - } errM]} { - catch {puts stderr "Failed to load punk::packagepreference"} - } - catch punk::packagepreference::install - } else { - # - } - - if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} { - - #still a caching version of auto_execok - but with proper(fixed) search order - - #set b [info body ::auto_execok] - #proc ::auto_execok_original name $b - - proc better_autoexec {{onoff ""}} { - variable better_autoexec - if {$onoff eq ""} { - return $better_autoexec - } - if {![string is boolean -strict $onoff]} { - error "better_autoexec argument 'onoff' must be a boolean, received: $onoff" - } - if {$onoff && ($onoff != $better_autoexec)} { - puts "Turning on better_autoexec - search PATH first then extension" - set better_autoexec 1 - proc ::punk::auto_execok_windows name { - ::punk::auto_execok_better $name - } - punk::rehash - } elseif {!$onoff && ($onoff != $better_autoexec)} { - puts "Turning off better_autoexec - search extension then PATH" - set better_autoexec 0 - proc ::punk::auto_execok_windows name { - ::punk::auto_execok_original $name - } - punk::rehash - } else { - puts "no change" - } - } - #better_autoexec $better_autoexec ;#init to default - - - proc auto_execok_better name { - global auto_execs env tcl_platform - - if {[info exists auto_execs($name)]} { - return $auto_execs($name) - } - #puts stdout "[a+ red]...[a]" - set auto_execs($name) "" - - set shellBuiltins [list assoc cls copy date del dir echo erase exit ftype \ - md mkdir mklink move rd ren rename rmdir start time type ver vol] - if {[info exists env(PATHEXT)]} { - # Add an initial ; to have the {} extension check first. - set execExtensions [split ";$env(PATHEXT)" ";"] - } else { - set execExtensions [list {} .com .exe .bat .cmd] - } - - if {[string tolower $name] in $shellBuiltins} { - # When this is command.com for some reason on Win2K, Tcl won't - # exec it unless the case is right, which this corrects. COMSPEC - # may not point to a real file, so do the check. - set cmd $env(COMSPEC) - if {[file exists $cmd]} { - set cmd [file attributes $cmd -shortname] - } - return [set auto_execs($name) [list $cmd /c $name]] - } - - if {[llength [file split $name]] != 1} { - #has a path - foreach ext $execExtensions { - set file ${name}${ext} - if {[file exists $file] && ![file isdirectory $file]} { - return [set auto_execs($name) [list $file]] - } - } - return "" - } - - #change1 - #set path "[file dirname [info nameofexecutable]];.;" - set path "[file dirname [info nameofexecutable]];" - - if {[info exists env(SystemRoot)]} { - set windir $env(SystemRoot) - } elseif {[info exists env(WINDIR)]} { - set windir $env(WINDIR) - } - if {[info exists windir]} { - append path "$windir/system32;$windir/system;$windir;" - } - - foreach var {PATH Path path} { - if {[info exists env($var)]} { - append path ";$env($var)" - } - } - - #change2 - if {[file extension $name] ne "" && [string tolower [file extension $name]] in [string tolower $execExtensions]} { - set lookfor [list $name] - } else { - set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}] - } - #puts "-->$lookfor" - foreach dir [split $path {;}] { - set dir [string trim $dir {\\}] ;#trailing slash will result in a tail such as "/python.exe" - #set dir [file normalize $dir] - # Skip already checked directories - if {[info exists checked($dir)] || ($dir eq "")} { - continue - } - set checked($dir) {} - - #surprisingly fast - #set matches [glob -nocomplain -dir $dir -types f -tails {*}$lookfor] - ##puts "--dir $dir matches:$matches" - #if {[llength $matches]} { - # set file [file join $dir [lindex $matches 0]] - # #puts "--match0:[lindex $matches 0] file:$file" - # return [set auto_execs($name) [list $file]] - #} - - #what if it's a link? - #foreach match [glob -nocomplain -dir $dir -types f -tail {*}$lookfor] { - # set file [file join $dir $match] - # if {[file exists $file]} { - # return [set auto_execs($name) [list $file]] - # } - #} - - #safest? could be a link? - foreach match [glob -nocomplain -dir $dir -tail {*}$lookfor] { - set file [file join $dir $match] - if {[file exists $file] && ![file isdirectory $file]} { - return [set auto_execs($name) [list $file]] - } - } - } - - #foreach ext $execExtensions { - #unset -nocomplain checked - #foreach dir [split $path {;}] { - # # Skip already checked directories - # if {[info exists checked($dir)] || ($dir eq "")} { - # continue - # } - # set checked($dir) {} - # set file [file join $dir ${name}${ext}] - # if {[file exists $file] && ![file isdirectory $file]} { - # return [set auto_execs($name) [list $file]] - # } - #} - #} - return "" - } - - - - #review - what if punk package reloaded - but ::auto_execs has updated path for winget.exe? - #what if we create another interp and use the same ::auto_execs? The appdir won't be detected. - #TODO - see if there is a proper windows way to determine where the 'reparse point' apps are installed - - - - #winget is installed on all modern windows (but not on windows sandbox!) and is an example of the problem this addresses - #we target apps with same location - - #the main purpose of this override is to support windows app executables (installed as 'reparse points') - #for Tcl versions prior to the 2025-01 fix by APN https://core.tcl-lang.org/tcl/tktview/4f0b5767ac - #versions prior to this will use cmd.exe to resolve the links - set stackrecord [commandstack::rename_command -renamer ::punk auto_execok name { - #set windowsappdir "%appdir%" - upvar ::punk::can_exec_windowsapp can_exec_windowsapp - upvar ::punk::windowsappdir windowsappdir - upvar ::punk::cmdexedir cmdexedir - - if {$windowsappdir eq ""} { - #we are targeting the winget location under the presumption this is where microsoft store apps are stored as 'reparse points' - #Tcl (2025) can't exec when given a path to these 0KB files - #This path is probably something like C:/Users/username/AppData/Local/Microsoft/WindowsApps - if {!([info exists ::env(LOCALAPPDATA)] && - [file exists [set testapp [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]])} { - #should be unlikely to get here - unless LOCALAPPDATA missing (or winget.exe missing e.g windows sandbox) - set windowsappdir [file dirname [lindex [::punk::auto_execok_windows winget.exe] 0]] - catch {puts stderr "(resolved winget by search)"} - } else { - set windowsappdir [file dirname $testapp] - } - } - - #set default_auto [$COMMANDSTACKNEXT $name] - set default_auto [::punk::auto_execok_windows $name] - #if {$name ni {cmd cmd.exe}} { - # unset -nocomplain ::auto_execs - #} - - if {$default_auto eq ""} { - return - } - set namedir [file dirname [lindex $default_auto 0]] - - if {$namedir eq $windowsappdir} { - if {$can_exec_windowsapp eq "unknown"} { - if {[catch {exec [file join $windowsappdir winget.exe] --version}]} { - set can_exec_windowsapp 0 - } else { - set can_exec_windowsapp 1 - } - } - if {$can_exec_windowsapp} { - return [file join $windowsappdir $name] - } - if {$cmdexedir eq ""} { - #cmd.exe very unlikely to move - set cmdexedir [file dirname [lindex [::punk::auto_execok_windows cmd.exe] 0]] - #auto_reset never seems to exist as a command - because auto_reset deletes all commands in the ::auto_index - #anyway.. it has other side effects (affects auto_load) - } - return "[file join $cmdexedir cmd.exe] /c $name" - } - return $default_auto - }] - - - } - -} - - - -#repltelemetry cooperation with other packages such as shellrun -#Maintenance warning: shellrun expects repltelemetry_emmitters to exist if punk namespace exists -namespace eval punk { - variable repltelemetry_emmitters - #don't stomp.. even if something created this namespace in advance and is 'cooperating' a bit early - if {![info exists repltelemetry_emitters]} { - set repltelemetry_emmitters [list] - } -} - -namespace eval punk::pipecmds { - #where to install proc/compilation artifacts for pieplines - namespace export * -} -namespace eval punk::pipecmds::split_patterns {} -namespace eval punk::pipecmds::split_rhs {} -namespace eval punk::pipecmds::var_classify {} -namespace eval punk::pipecmds::destructure {} -namespace eval punk::pipecmds::insertion {} - - -#globals... some minimal global var pollution -#punk's official silly test dictionary -set punk_testd [dict create \ - a0 a0val \ - b0 [dict create \ - a1 b0a1val \ - b1 b0b1val \ - c1 b0c1val \ - d1 b0d1val \ - ] \ - c0 [dict create] \ - d0 [dict create \ - a1 [dict create \ - a2 d0a1a2val \ - b2 d0a1b2val \ - c2 d0a1c2val \ - ] \ - b1 [dict create \ - a2 [dict create \ - a3 d0b1a2a3val \ - b3 d0b1a2b3val \ - ] \ - b2 [dict create \ - a3 d0b1b2a3val \ - bananas "in pyjamas" \ - c3 [dict create \ - po "in { }" \ - b4 ""\ - c4 "can go boom" \ - ] \ - d3 [dict create \ - a4 "-paper -cuts" \ - ] \ - e3 [dict create] \ - ] \ - ] \ - ] \ - e0 "multi\nline"\ - ] -#test dict 2 - uniform structure and some keys with common prefixes for glob matching -set punk_testd2 [dict create \ - a0 [dict create \ - b1 {a b c}\ - b2 {a b c d}\ - x1 {x y z 1 2}\ - y2 {X Y Z 1 2}\ - z1 {k1 v1 k2 v2 k3 v3}\ - ] \ - a1 [dict create \ - b1 {a b c}\ - b2 {a b c d}\ - x1 {x y z 1 2}\ - y2 {X Y Z 1 2}\ - z1 {k1 v1 k2 v2 k3 v3}\ - ] \ - b1 [dict create \ - b1 {a b c}\ - b2 {a b c d}\ - x1 {x y z 1 2}\ - y2 {X Y Z 1 2}\ - z1 {k1 v1 k2 v2 k3 v3}\ - ] \ -] - -#impolitely cooperative with punk repl - todo - tone it down. -#namespace eval ::punk::repl::codethread { -# variable running 0 -#} -package require punk::lib ;# subdependency punk::args -package require punk::ansi -if {![llength [info commands ::ansistring]]} { - namespace import punk::ansi::ansistring -} -#require aliascore after punk::lib & punk::ansi are loaded -package require punk::aliascore ;#mostly punk::lib aliases -punk::aliascore::init -force 1 - -package require punk::repl::codethread -package require punk::config -#package require textblock -package require punk::console ;#requires Thread -package require punk::ns -package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems -package require punk::repo -package require punk::du -package require punk::mix::base -package require base64 - -package require punk::pipe - -namespace eval punk { - # -- --- --- - #namespace import ::control::assert ;#according to tcllib doc - assert can be enabled/disabled per namespace - # using control::control assert enabled within a namespace for which ::control::assert wasn't imported can produce surprising results. - #e.g setting to zero may keep asserts enabled - (e.g if the assert command is still available due to namespace path etc) - but.. querying the enabled status may show zero even in the parent namespace where asserts also still work. - #package require control - #control::control assert enabled 1 - - #We will use punk::assertion instead - - package require punk::assertion - if {[catch {namespace import ::punk::assertion::assert} errM]} { - catch { - puts stderr "punk error importing punk::assertion::assert\n$errM" - puts stderr "punk::a* commands:[info commands ::punk::a*]" - } - } - punk::assertion::active on - # -- --- --- - - interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system - if {[catch { - package require pattern - } errpkg]} { - catch {puts stderr "Failed to load package pattern error: $errpkg"} - } - package require shellfilter - package require punkapp - package require funcl - - package require struct::list - package require fileutil - #package require punk::lib - - #NOTE - always call debug.xxx with braced message instead of double-quoted (unless specifically intending to do double-subtition) - #(or $ within values will be substituted, causing an extra error message if the var doesn't exist - which it quite possibly doesn't) - package require debug - - debug define punk.unknown - debug define punk.pipe - debug define punk.pipe.var - debug define punk.pipe.args - debug define punk.pipe.rep ;#string/list representation with tcl::unsupported::representation - debug define punk.pipe.compile ;#info about when we compile pipeline components into procs etc - - - #----------------------------------- - # todo - load initial debug state from config - debug off punk.unknown - debug level punk.unknown 1 - debug off punk.pipe - debug level punk.pipe 4 - debug off punk.pipe.var - debug level punk.pipe.var 4 - debug off punk.pipe.args - debug level punk.pipe.args 3 - debug off punk.pipe.rep 2 - debug off punk.pipe.compile - debug level punk.pipe.compile 2 - - - debug header "dbg> " - - - variable last_run_display [list] - - - #variable re_headvar1 {([a-zA-Z:@.(),]+?)(?![^(]*\))(,.*)*$} - - - - #----------------------------------------------------------------------------------- - #strlen is important for testing issues with string representationa and shimmering. - #This specific implementation with append (as at 2023-09) is designed to ensure the original str representation isn't changed - #It may need to be reviewed with different Tcl versions in case the append empty string is 'optimised/tuned' in some way that affects the behaviour - proc strlen {str} { - append str2 $str {} - string length $str2 - } - #----------------------------------------------------------------------------------- - - #get a copy of the item without affecting internal rep - proc objclone {obj} { - append obj2 $obj {} - } - proc set_clone {varname obj} { - #maintenance: also punk::lib::set_clone - #e.g used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] - append obj2 $obj {} - uplevel 1 [list set $varname $obj2] - } - - interp alias "" strlen "" ::punk::strlen - interp alias "" str_len "" ::punk::strlen - interp alias "" objclone "" ::punk::objclone - #proc ::strlen {str} { - # string length [append str2 $str {}] - #} - #proc ::objclone {obj} { - # append obj2 $obj {} - #} - - #----------------------------------------------------------------------------------- - #order of arguments designed for pipelining - #review - 'piper_' prefix is a naming convention for functions that are ordered for tail-argument pipelining - #piper_ function names should read intuitively when used in a pipeline with tail argument supplied by the pipeline - but may seem reversed when using standalone. - proc piper_append {new base} { - append base $new - } - interp alias "" piper_append "" ::punk::piper_append - proc piper_prepend {new base} { - append new $base - } - interp alias "" piper_prepend "" ::punk::piper_prepend - - proc ::punk::K {x y} { return $x} - - #todo ansigrep? e.g grep using ansistripped value - proc grepstr1 {pattern data} { - set data [string map {\r\n \n} $data] - set lines [split $data \n] - set matches [lsearch -all -regexp $lines $pattern] - set max [lindex $matches end] - set w1 [string length $max] - set result "" - set H [a+ green bold overline] - set R \x1b\[m - foreach m $matches { - set ln [lindex $lines $m] - set ln [regsub -all $pattern $ln $H&$R] - append result [format %${w1}s $m] " $ln" \n - } - set result [string trimright $result \n] - return $result - } - - #---------------------- - #todo - fix overtype - #create test - #overtype::renderline -insert_mode 0 -transparent 1 [a+ green]-----[a] " [a+ underline]x[a]" - #---------------------- - - - punk::args::define { - @id -id ::punk::grepstr - @cmd -name punk::grepstr\ - -summary\ - "Grep for regex pattern in plaintext of supplied (possibly ANSI) string."\ - -help\ - "The grepstr command can find strings in ANSI text even if there are interspersed - ANSI colour codes etc. Even if a word has different coloured/styled letters, the - regex can match the plaintext. (Search is performed on ansistripped text, and then - the matched sections are highlighted and overlayed on the original styled/colourd - input. - If the input string has ANSI movement codes - the resultant text may not be directly - searchable because the parts of a word may be separated by various codes and other - plain text. To search such an input string, the string should first be 'rendered' to - a form where the ANSI only represents SGR styling (and perhaps other non-movement - codes) using something like overtype::renderline or overtype::rendertext." - - @leaders -min 0 -max 0 - @opts - -returnlines -type string -typesynopsis matched|all -default breaksandmatches -choicecolumns 1 -choices {matched all breaksandmatches} -choicelabels { - "matched"\ - " Return only lines that matched." - "breaksandmatches"\ - " Return configured --break= lines in between non-consecutive matches" - "all"\ - " Return all lines. - This has a similar effect to the 'grep' trick of matching on 'pattern|$' - (The $ matches all lines that have an end; ie all lines, but there is no - associated character to which to apply highlighting) - except that when instead using -returnlines all with --line-number, the * - indicator after the linenumber will only be highlighted for lines with matches, - and the following matchcount will indicate zero for non-matching lines." - } - -B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num - -C|--context= -parsekey "--context" -default 0 -type integer -typesynopsis num -help\ - "Print num lines of leading and trailing context surrounding each match." - -A|--after-context= -parsekey "--after-context" -default 0 -type integer -typesynopsis num - --break= -type string -default "-- %c%\U2260" -help\ - "When returning matched lines and there is a break in consecutive output, - display the break with the given string. %c% is a placeholder for the - number of lines skipped. - Use empty-string for an empty line as a break display. - grepstr --break= needle $haystacklines - - The unix grep utility commonly uses -- for this indicator. - grepstr --break=-- needle $haystacklines - - Customisation example: - grepstr -n \"--break=(skipped %c% lines)\" needle $haystacklines - " - -ansistrip -type none -help\ - "Strip all ansi codes from the input string before processing. - This is not necessary for regex matching purposes, as the matching is always - performed on the ansistripped characters anyway, but by stripping ANSI, the - result only has the ANSI supplied by the -highlight option." - - #-n|--line-number as per grep utility, except that we include a * for matches - -n|--line-number -type none -help\ - "Each output line is preceded by its relative line number in the file, starting at line 1. - For lines that matched the regex, the line number will be suffixed with a * indicator - with the same highlighting as the matched string(s). - The number of matches in the line immediately follows the * - For lines with no matches the * indicator is present with no highlighting and suffixed - with zeros." - -i|--ignore-case -type none -help\ - "Perform case insensitive matching." - -highlight -type list -typesynopsis ansinames -default {green bold Black underline overline} -help\ - "list of ANSI SGR style codes as supported by and documented in punk::ansi::a?" - -- -type none - @values - pattern -type string -help\ - "regex pattern to match in plaintext portion of ANSI string" - string -type string - } - proc grepstr {args} { - lassign [dict values [punk::args::parse $args withid ::punk::grepstr]] leaders opts values received - set pattern [dict get $values pattern] - set data [dict get $values string] - set do_strip 0 - if {[dict exists $received -ansistrip]} { - set data [punk::ansi::ansistrip $data] - } - set highlight [dict get $opts -highlight] - set opt_returnlines [dict get $opts -returnlines] - set context [dict get $opts --context] ;#int - set beforecontext [dict get $opts --before-context] - set beforecontext [expr {max($beforecontext,$context)}] - set aftercontext [dict get $opts --after-context] - set aftercontext [expr {max($aftercontext,$context)}] - set break [dict get $opts --break] - set ignorecase [dict exists $received --ignore-case] - if {$ignorecase} { - set nocase "-nocase" - } else { - set nocase "" - } - - - if {[dict exists $received --line-number]} { - set do_linenums 1 ;#display lineindex+1 - } else { - set do_linenums 0 - } - - if {[llength $highlight] == 0} { - set H "" - set R "" - } else { - set H [a+ {*}$highlight] - set R \x1b\[m - } - - set data [string map {\r\n \n} $data] - if {![punk::ansi::ta::detect $data]} { - set lines [split $data \n] - set matches [lsearch -all {*}$nocase -regexp $lines $pattern] - set result "" - if {$opt_returnlines eq "all"} { - set returnlines [punk::lib::range 0 [llength $lines]-1] - } else { - #matches|breaksandmatches - set returnlines $matches - } - set max [lindex $returnlines end] - if {[string is integer -strict $max]} { - incr max - } - set w1 [string length $max] - #lineindex is zero based - display of linenums is 1 based - set resultlines [dict create] - foreach lineindex $returnlines { - set ln [lindex $lines $lineindex] - set col1 "" - if {$do_linenums} { - set col1 [format "%${w1}s " [expr {$lineindex+1}]] - } - if {$lineindex in $matches} { - set ln [regsub -all {*}$nocase -- $pattern $ln $H&$R] ;#n - set matchcount [regexp -all {*}$nocase -- $pattern $ln] - if {$do_linenums} { - append col1 $H*$R[format %03s $matchcount] - } - } else { - if {$do_linenums} { - append col1 "*000" - } - } - #--------------------------------------------------------------- - set prelines [lrange $lines $lineindex-$beforecontext $lineindex-1] - set s [expr {$lineindex-$beforecontext-1}] - if {$s < -1} {set s -1} - foreach p $prelines { - incr s - #append result "[format %${w1}s [expr {$s+1}]]- " " " $p \n - if {![dict exists $resultlines $s]} { - if {$do_linenums} { - set show "[format "%${w1}s " [expr {$s+1}]]- $p" - } else { - set show $p - } - dict set resultlines $s $show - } - } - #--------------------------------------------------------------- - if {$do_linenums} { - set show "$col1 $ln" - } else { - set show $ln - } - dict set resultlines $lineindex $show - #--------------------------------------------------------------- - set postlines [lrange $lines $lineindex+1 $lineindex+$aftercontext] - set s $lineindex - foreach p $postlines { - incr s - if {![dict exists $resultlines $s]} { - if {$do_linenums} { - set show "[format "%${w1}s " [expr {$s+1}]]- $p" - } else { - set show $p - } - dict set resultlines $s $show - } - } - #--------------------------------------------------------------- - - } - } else { - set plain [punk::ansi::ansistrip $data] - set plainlines [split $plain \n] - set lines [split $data \n] - set matches [lsearch -all {*}$nocase -regexp $plainlines $pattern] - if {$opt_returnlines eq "all"} { - set returnlines [punk::lib::range 0 [llength $lines]-1] - } else { - set returnlines $matches - } - set max [lindex $returnlines end] - if {[string is integer -strict $max]} { - #if max index is 9 - linenum will be 10, (99->100 etc) - so add one in case we're on such a boundary. - incr max - } - set w1 [string length $max] - set result "" - set placeholder \UFFEF ;#review - set resultlines [dict create] - foreach lineindex $returnlines { - set ln [lindex $lines $lineindex] - set col1 "" - if {$do_linenums} { - set col1 [format "%${w1}s " [expr {$lineindex+1}]] - } - if {$lineindex in $matches} { - set plain_ln [lindex $plainlines $lineindex] - set parts [regexp -all {*}$nocase -indices -inline -- $pattern $plain_ln] - set matchcount [llength $parts] - if {$do_linenums} { - append col1 $H*$R[format %03s $matchcount] - } - if {[llength $parts] == 0} { - #This probably can't happen (?) - #If it does.. it's more likely to be an issue with our line index than with regexp - puts stderr "Unexpected regex mismatch in grepstr - line marked with ??? (shouldn't happen)" - set matchshow "??? $ln" - #dict set resultlines $lineindex $show - } else { - set overlay "" - set i 0 - foreach prange $parts { - lassign $prange s e - set prelen [expr {$s - $i}] - append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e]$R - set i [expr {$e + 1}] - } - set tail [string range $plain_ln $e+1 end] - append overlay [string repeat $placeholder [string length $tail]] - #puts "$overlay" - #puts "$ln" - set rendered [overtype::renderline -transparent $placeholder -insert_mode 0 $ln $overlay] - if {$do_linenums} { - set matchshow "$col1 $rendered" - } else { - set matchshow $rendered - } - } - #--------------------------------------------------------------- - set prelines [lrange $lines $lineindex-$beforecontext $lineindex-1] - set s [expr {$lineindex-$beforecontext-1}] - if {$s < -1} {set s -1} - foreach p $prelines { - incr s - #append result "[format %${w1}s [expr {$s+1}]]- " " " $p \n - if {![dict exists $resultlines $s]} { - if {$do_linenums} { - set show "[format "%${w1}s " [expr {$s+1}]]- $p" - } else { - set show $p - } - dict set resultlines $s $show - } - } - #--------------------------------------------------------------- - dict set resultlines $lineindex $matchshow - #--------------------------------------------------------------- - set postlines [lrange $lines $lineindex+1 $lineindex+$aftercontext] - set s $lineindex - foreach p $postlines { - incr s - if {![dict exists $resultlines $s]} { - if {$do_linenums} { - set show "[format "%${w1}s " [expr {$s+1}]]- $p" - } else { - set show $p - } - dict set resultlines $s $show - } - } - #--------------------------------------------------------------- - } else { - if {$do_linenums} { - append col1 "*000" - set show "$col1 $ln" - } else { - set show $ln - } - dict set resultlines $lineindex $show - } - } - } - set ordered_resultlines [lsort -integer [dict keys $resultlines]] - set result "" - set i -1 - set do_break 0 - if {$opt_returnlines eq "breaksandmatches"} { - set do_break 1 - } - if {$do_break} { - foreach r $ordered_resultlines { - incr i - if {$r > $i} { - set c [expr {$r - $i}] - append result [string map [list %c% $c] $break] \n - } - append result [dict get $resultlines $r] \n - set i $r - } - if {$i<[llength $lines]-1} { - set c [expr {[llength $lines]-1-$i}] - append result [string map [list %c% $c] $break] \n - } - } else { - foreach r $ordered_resultlines { - append result [dict get $resultlines $r] \n - } - } - set result [string trimright $result \n] - return $result - } - - proc stacktrace {} { - set stack "Stack trace:\n" - for {set i 1} {$i < [info level]} {incr i} { - set lvl [info level -$i] - set pname [lindex $lvl 0] - append stack [string repeat " " $i]$pname - - if {![catch {info args $pname} pargs]} { - foreach value [lrange $lvl 1 end] arg $pargs { - - if {$value eq ""} { - if {$arg != 0} { - info default $pname $arg value - } - } - append stack " $arg='$value'" - } - } else { - append stack " !unknown vars for $pname" - } - - append stack \n - } - return $stack - } - - #review - there are various type of uuid - we should use something consistent across platforms - #twapi is used on windows because it's about 5 times faster - but is this more important than consistency? - #twapi is much slower to load in the first place (e.g 75ms vs 6ms if package names already loaded) - so for oneshots tcllib uuid is better anyway - #(counterpoint: in the case of punk - we currently need twapi anyway on windows) - #does tcllib's uuid use the same mechanisms on different platforms anyway? - proc ::punk::uuid {} { - set has_twapi 0 - if 0 { - if {"windows" eq $::tcl_platform(platform)} { - if {![catch { - set loader [zzzload::pkg_wait twapi] - } errM]} { - if {$loader in [list failed loading]} { - catch {puts stderr "Unexpected problem during thread-load of pkg twapi - zzload::pkg_wait returned $loader"} - } - } else { - package require twapi - } - if {[package provide twapi] ne ""} { - set has_twapi 1 - } - } - } - if {!$has_twapi} { - if {[catch {package require uuid} errM]} { - error "Unable to load a package for uuid on this platform. Try installing tcllib's uuid (any platform) - or twapi for windows" - } - return [uuid::uuid generate] - } else { - return [twapi::new_uuid] - } - } - - #get last command result that was run through the repl - proc ::punk::get_runchunk {args} { - set argd [punk::args::parse $args withdef { - @id -id ::punk::get_runchunk - @cmd -name "punk::get_runchunk" -help\ - "experimental" - @opts - -1 -optional 1 -type none - -2 -optional 1 -type none - @values -min 0 -max 0 - }] - #todo - make this command run without truncating previous runchunks - set runchunks [tsv::array names repl runchunks-*] - - set sortlist [list] - foreach cname $runchunks { - set num [lindex [split $cname -] 1] - lappend sortlist [list $num $cname] - } - set sorted [lsort -index 0 -integer $sortlist] - set chunkname [lindex $sorted end-1 1] - set runlist [tsv::get repl $chunkname] - #puts stderr "--$runlist" - if {![llength $runlist]} { - return "" - } else { - return [lindex [lsearch -inline -index 0 $runlist result] 1] - } - } - interp alias {} _ {} ::punk::get_runchunk - - - proc ::punk::var {varname {= _=.=_} args} { - upvar $varname the_var - switch -exact -- ${=} { - = { - if {[llength $args] > 1} { - set the_var $args - } else { - set the_var [lindex $args 0] - } - } - .= { - if {[llength $args] > 1} { - set the_var [uplevel 1 $args] - } else { - set the_var [uplevel 1 [lindex $args 0]] - } - } - _=.=_ { - set the_var - } - default { - set the_var [list ${=} {*}$args] - } - } - } - proc src {args} { - #based on wiki.. https://wiki.tcl-lang.org/page/source+with+args - #added support for ?-encoding name? and other options of Tcl source command under assumption they come pairs before the filename - # review? seems unlikely source command will ever accept solo options. It would make complete disambiguation impossible when passing additional args as we are doing here. - set cmdargs [list] - set scriptargs [list] - set inopts 0 - set i 0 - foreach a $args { - if {$i eq [llength $args]-1} { - #reached end without finding end of opts - #must be file - even if it does match -* ? - break - } - if {!$inopts} { - if {[string match -* $a]} { - set inopts 1 - } else { - #leave loop at first nonoption - i should be index of file - break - } - } else { - #leave for next iteration to check - set inopts 0 - } - incr i - } - set cmdargs [lrange $args 0 $i] - set scriptargs [lrange $args $i+1 end] - set argv $::argv - set argc $::argc - set ::argv $scriptargs - set ::argc [llength $scriptargs] - set code [catch {uplevel [list source {*}$cmdargs]} return] - set ::argv $argv - set ::argc $argc - return -code $code $return - } - - - - - proc varinfo {vname {flag ""}} { - upvar $vname v - if {[array exists $vname]} { - error "can't read \"$vname\": variable is array" - } - if {[catch {set v} err]} { - error "can't read \"$vname\": no such variable" - } - set inf [shellfilter::list_element_info [list $v]] - set inf [dict get $inf 0] - if {$flag eq "-v"} { - return $inf - } - - set output [dict create] - dict set output wouldbrace [dict get $inf wouldbrace] - dict set output wouldescape [dict get $inf wouldescape] - dict set output head_tail_names [dict get $inf head_tail_names] - dict set output len [dict get $inf len] - return $output - } - - #review - extending core commands could be a bit intrusive...although it can make sense in a pipeline. - #e.g contrived pipeline example to only allow setting existing keys - ## .= @head.= list {a aaa b bbb c ccc} |d,dkeys@keys> |> &true.= {is_list_all_in_list $nkeys $dkeys} |> {dict modify d {*}$new} |> &true.= {is_list_all_ni_list $nkeys $dkeys} |> {dict modify d {*}$new} -1} { - #lassign [punk::lib::string_splitbefore $token $first_term] v k - set v [string range $token 0 $first_term-1] - set k [string range $token $first_term end] ;#key section includes the terminal char - lappend varlist [list $v $k] - } else { - lappend varlist [list $token ""] - } - set token "" - set token_index -1 ;#reduce by 1 because , not included in next token - set first_term -1 - } else { - if {$first_term == -1} { - if {$c in $var_terminals} { - set first_term $token_index - } - } - append token $c - if {$c eq "("} { - set in_brackets 1 - } - } - } - incr token_index - } - if {[string length $token]} { - if {$first_term > -1} { - set v [string range $token 0 $first_term-1] - set k [string range $token $first_term end] ;#key section includes the terminal char - lappend varlist [list $v $k] - } else { - lappend varlist [list $token ""] - } - } - return $varlist - } - - proc fp_restructure {selector data} { - if {$selector eq ""} { - fun=.= {val $input} and always break - set lhs "" - set rhs "" - #todo - check performance impact of catches around list and dict operations - consider single catch around destructure and less specific match error info? - foreach index $subindices { - set subpath [join [lrange $subindices 0 $i_keyindex] /] - set lhs $subpath - set assigned "" - set get_not 0 - set already_assigned 0 - set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. - #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. - #todo - see if 'string is list' improved in tcl9 vs catch {llength $list} - switch -exact -- $index { - # { - set active_key_type "list" - if {![catch {llength $leveldata} assigned]} { - set already_assigned 1 - } else { - set action ?mismatch-not-a-list - break - } - } - ## { - set active_key_type "dict" - if {![catch {dict size $leveldata} assigned]} { - set already_assigned 1 - } else { - set action ?mismatch-not-a-dict - break - } - } - #? { - #review - compare to %# ????? - #seems to be unimplemented ? - set assigned [string length $leveldata] - set already_assigned 1 - } - @ { - upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position - set active_key_type "list" - #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey - #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 - #while x@,y@.= is reasonably handy - especially for args e.g $len} { - set action ?mismatch-list-index-out-of-range - break - } - set assigned [lindex $leveldata $index] - set already_assigned 1 - } - @@ - @?@ - @??@ { - set active_key_type "dict" - - #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc - #x@@ = a {x y} - #x@@/@0 = a - #x@@/@1 = x y - #x@@/a = a {x y} - # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. - # (note that ?@ forms a different subpath - so can be used to test match prior to @@ without affecting the index) - # It is analogous to v1@,v2@ for lists. - # @pairs is more useful for repeated operations - - # - #set subpath [join [lrange $subindices 0 $i_keyindex] /] - if {[catch {dict size $leveldata} dsize]} { - set action ?mismatch-not-a-dict - break - } - set next_this_level [incr v_dict_idx($subpath)] - set keyindex [expr {$next_this_level -1}] - if {($keyindex + 1) <= $dsize} { - set k [lindex [dict keys $leveldata] $keyindex] - if {$index eq "@?@"} { - set assigned [dict get $leveldata $k] - } else { - set assigned [list $k [dict get $leveldata $k]] - } - } else { - if {$index eq "@@"} { - set action ?mismatch-dict-index-out-of-range - break - } else { - set assigned [list] - } - } - set already_assigned 1 - } - default { - switch -glob -- $index { - @@* { - set active_key_type "dict" - set key [string range $index 2 end] - #dict exists test is safe - no need for catch - if {[dict exists $leveldata $key]} { - set assigned [dict get $leveldata $key] - } else { - set action ?mismatch-dict-key-not-found - break - } - set already_assigned 1 - } - {@\?@*} { - set active_key_type "dict" - set key [string range $index 3 end] - #dict exists test is safe - no need for catch - if {[dict exists $leveldata $key]} { - set assigned [dict get $leveldata $key] - } else { - set assigned [list] - } - set already_assigned 1 - } - {@\?\?@*} { - set active_key_type "dict" - set key [string range $index 4 end] - #dict exists test is safe - no need for catch - if {[dict exists $leveldata $key]} { - set assigned [list $key [dict get $leveldata $key]] - } else { - set assigned [list] - } - set already_assigned 1 - } - @* { - set active_key_type "list" - set do_bounds_check 1 - set index [string trimleft $index @] - } - default { - # - } - } - - if {!$already_assigned} { - if {[string match "not-*" $index] && $active_key_type in [list "" "list"]} { - #e.g not-0-end-1 not-end-4-end-2 - set get_not 1 - #cherry-pick some easy cases, and either assign, or re-map to corresponding index - switch -- $index { - not-tail { - set active_key_type "list" - set assigned [lindex $leveldata 0]; set already_assigned 1 - } - not-head { - set active_key_type "list" - #set selector "tail"; set get_not 0 - set assigned [lrange $leveldata 1 end]; set already_assigned 1 - } - not-end { - set active_key_type "list" - set assigned [lrange $leveldata 0 end-1]; set already_assigned 1 - } - default { - #trim off the not- and let the remaining index handle based on get_not being 1 - set index [string range $index 4 end] - } - } - } - } - } - } - - if {!$already_assigned} { - - #keyword 'pipesyntax' at beginning of error message - set listmsg "pipesyntax Unable to interpret subindex $index\n" - append listmsg "selector: '$selector'\n" - append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n" - append listmsg "Additional accepted keywords include: head tail\n" - append listmsg "Use var@@key to treat value as a dict and retrieve element at key" - - - #we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against - #need to set a corresponding action - if {$active_key_type in [list "" "list"]} { - set active_key_type "list" - #for pattern matching purposes - head/tail not valid on empty lists (similar to elixir) - if {$index eq "0"} { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - break - } - set assigned [lindex $leveldata 0] - } elseif {$index eq "head"} { - #NOTE: /@head and /head both do bounds check. This is intentional - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - break - } - if {$len == 0} { - set action ?mismatch-list-index-out-of-range-empty - break - } - #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax - set assigned [lindex $leveldata 0] - } elseif {$index eq "end"} { - # @end /end - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - break - } - if {$do_bounds_check && $len < 1} { - set action ?mismatch-list-index-out-of-range - } - set assigned [lindex $leveldata end] - } elseif {$index eq "tail"} { - #NOTE: /@tail and /tail both do bounds check. This is intentional. - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - break - } - #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list - #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. - #In this way tail is different to @1-end - if {$len == 0} { - set action ?mismatch-list-index-out-of-range - break - } - set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero. - } elseif {$index eq "anyhead"} { - # @anyhead - #allow returning of head or nothing if empty list - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - break - } - set assigned [lindex $leveldata 0] - } elseif {$index eq "anytail"} { - # @anytail - #allow returning of tail or nothing if empty list - #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead. - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - break - } - set assigned [lrange $leveldata 1 end] - } elseif {$index eq "init"} { - # @init - #all but last element - same as haskell 'init' - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - break - } - set assigned [lrange $leveldata 0 end-1] - } elseif {$index eq "list"} { - # @list - #allow returning of entire list even if empty - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - break - } - set assigned $leveldata - } elseif {$index eq "raw"} { - #no list checking.. - set assigned $leveldata - } elseif {$index eq "keys"} { - #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements - if {[catch {dict size $leveldata} dsize]} { - set action ?mismatch-not-a-dict - break - } - set assigned [dict keys $leveldata] - } elseif {$index eq "values"} { - #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements - if {[catch {dict size $leveldata} dsize]} { - set action ?mismatch-not-a-dict - break - } - set assigned [dict values $leveldata] - } elseif {$index eq "pairs"} { - if {[catch {dict size $leveldata} dsize]} { - set action ?mismatch-not-a-dict - break - } - #set assigned [dict values $leveldata] - set pairs [list] - tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]} - set assigned [lindex [list $pairs [unset pairs]] 0] - } elseif {[string is integer -strict $index]} { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - break - } - # only check if @ was directly in original index section - if {$do_bounds_check && ($index+1 > $len || $index < 0)} { - set action ?mismatch-list-index-out-of-range - break - } - if {$get_not} { - #already handled not-0 - set assigned [lreplace $leveldata $index $index] - } else { - set assigned [lindex $leveldata $index] - } - } elseif {[string first "end" $index] >=0} { - if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - break - } - #leave the - from the end- as part of the offset - set offset [expr $endspec] ;#don't brace! (consider: set x --34;puts expr $j;puts expr {$j} ) - if {$do_bounds_check && ($offset > 0 || abs($offset) >= $len)} { - set action ?mismatch-list-index-out-of-range - break - } - if {$get_not} { - set assigned [lreplace $leveldata $index $index] - } else { - set assigned [lindex $leveldata $index] - } - } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - break - } - if {$do_bounds_check && [string is integer -strict $start]} { - if {$start+1 > $len || $start < 0} { - set action ?mismatch-list-index-out-of-range - break - } - } elseif {$start eq "end"} { - #ok - } elseif {$do_bounds_check} { - set startoffset [string range $start 3 end] ;#include the - from end- - set startoffset [expr $startoffset] ;#don't brace! - if {$startoffset > 0 || abs($startoffset) >= $len} { - set action ?mismatch-list-index-out-of-range - break - } - } - if {$do_bounds_check && [string is integer -strict $end]} { - if {$end+1 > $len || $end < 0} { - set action ?mismatch-list-index-out-of-range - break - } - } elseif {$end eq "end"} { - #ok - } elseif {$do_bounds_check} { - set endoffset [string range $end 3 end] ;#include the - from end- - set endoffset [expr $endoffset] ;#don't brace! - if {$endoffset > 0 || abs($endoffset) >= $len} { - set action ?mismatch-list-index-out-of-range - break - } - } - if {$get_not} { - set assigned [lreplace $leveldata $start $end] - } else { - set assigned [lrange $leveldata $start $end] - } - } else { - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] - } - } elseif {[string first - $index] > 0} { - puts "====> index:$index leveldata:$leveldata" - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - break - } - #handle pure int-int ranges separately - set testindex [string map [list - "" + ""] $index] - if {[string is digit -strict $testindex]} { - #don't worry about leading - negative value for indices not valid anyway - set parts [split $index -] - if {[llength $parts] != 2} { - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] - } - lassign $parts start end - if {$start+1 > $len || $end+1 > $len} { - set action ?mismatch-not-a-list - break - } - if {$get_not} { - set assigned [lreplace $leveldata $start $end] - } else { - set assigned [lrange $leveldata $start $end] - } - } else { - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] - } - - } else { - #keyword 'pipesyntax' at beginning of error message - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] - } - } else { - #treat as dict key - set active_key_type "dict" - if {[dict exists $leveldata $index]} { - set assigned [dict get $leveldata $index] - } else { - set action ?mismatch-dict-key-not-found - break - } - - } - } - set leveldata $assigned - set rhs $leveldata - #don't break on empty data - operations such as # and ## can return 0 - #if {![llength $leveldata]} { - # break - #} - incr i_keyindex - } - #puts stdout "----> destructure rep leveldata: [rep $leveldata]" - #puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]" - - #maintain key order - caller unpacks using lassign - return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] - - } - #todo - fp_destructure - return a function-pipeline that can then be transformed to a funcl and finally a more efficient tcl script - proc destructure_func {selector data} { - #puts stderr ".d." - set selector [string trim $selector /] - #upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position - #upvar v_dict_idx v_dict_idx ;#positional tracker for /@@ - dict position - - #map some problematic things out of the way in a manner that maintains some transparency - #e.g glob chars ? * in a command name can make testing using {[info commands $cmd] ne ""} produce spurious results - requiring a stricter (and slower) test such as {$cmd in [info commands $cmd]} - #The selector forms part of the proc name - #review - compare with pipecmd_namemapping - set selector_safe [string map [list\ - ? \ - * \ - \\ \ - {"} \ - {$} \ - "\x1b\[" \ - "\x1b\]" \ - {[} \ - {]} \ - :: \ - {;} \ - " " \ - \t \ - \n \ - \r \ - ] $selector] - - set cmdname ::punk::pipecmds::destructure::_$selector_safe - if {[info commands $cmdname] ne ""} { - return [$cmdname $data] ;# note upvar 2 for stateful v_list_idx to be resolved in _multi_bind_result context - } - - set leveldata $data - set body [destructure_func_build_procbody $cmdname $selector $data] - - puts stdout ---- - puts stderr "proc $cmdname {leveldata} {" - puts stderr $body - puts stderr "}" - puts stdout --- - proc $cmdname {leveldata} $body - #eval $script ;#create the proc - debug.punk.pipe.compile {proc $cmdname} 4 - #return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] - #use return - script has upvar 2 for v_list_idx to be resolved in _multi_bind_result context - return [$cmdname $data] - } - - #Builds a *basic* function to do the destructuring. - #This is simply a set of steps to destructure each level of the data based on the hierarchical selector. - #It just uses intermediate variables and adds some comments to the code to show the indices used at each point. - #This may be useful in the long run as a debug/fallback mechanism - but ideally we should be building a more efficient script. - proc destructure_func_build_procbody {cmdname selector data} { - set script "" - #place selector in comment in script only - if there is an error in selector we pick it up when building the script. - #The script itself should only be returning errors in its action key of the result dictionary - append script \n [string map [list $selector] {# set selector {}}] - set subindices [split $selector /] - append script \n [string map [list [list $subindices]] {# set subindices }] - set action ?match ;#default assumption. Alternatively set to ?mismatch or ?mismatch- and always break - append script \n {set action ?match} - #append script \n {set assigned ""} ;#review - set active_key_type "" - append script \n {# set active_key_type ""} - set lhs "" - #append script \n [tstr {set lhs ${{$lhs}}}] - append script \n {set lhs ""} - set rhs "" - append script \n {set rhs ""} - - set INDEX_OPERATIONS {} ;#caps to make clear in templates that this is substituted from script building scope - - #maintain key order - caller unpacks using lassign - set returnline {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} - set return_template {return [tcl::dict::create -assigned $leveldata -action $action -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} - #set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs $rhs -index_operations {${$INDEX_OPERATIONS}}]} - set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} - set tpl_return_mismatch_not_a_list {return [dict create -assigned $leveldata -action ?mismatch-not-a-list -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} - set tpl_return_mismatch_list_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} - set tpl_return_mismatch_list_index_out_of_range_empty {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range-empty -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} - set tpl_return_mismatch_not_a_dict {return [dict create -assigned $leveldata -action ?mismatch-not-a-dict -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} - #dict 'index' when using stateful @@ etc to iterate over dict instead of by key - set tpl_return_mismatch_dict_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-dict-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} - set tpl_return_mismatch_dict_key_not_found {return [dict create -assigned $leveldata -action ?mismatch-dict-key-not-found -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} - - - if {![string length $selector]} { - #just return $leveldata - set script { - dict create -assigned $leveldata -action ?match -lhs "" -rhs $leveldata - } - return $script - } - - if {[string is digit -strict [join $subindices ""]]} { - #review tip 551 (tcl9+?) - #puts stderr ">>>>>>>>>>>>>>>> data: $leveldata selector: $selector subindices: $subindices" - #pure numeric keylist - put straight to lindex - # - #NOTE: this direct access e.g v/0/1/2 doesn't check out of bounds which is at odds with list access containing @ - #We will leave this as a syntax for different (more performant) behaviour - #- it's potentially a little confusing - but it would be a shame not to have the possibility to take advantage of the lindex deep indexing capability in pattern matching. - #TODO - review and/or document - # - #Todo - add a handler for v/n/n/n/n/# to allow unchecked counting at depth too. - #(or more generally - loop until we hit another type of subindex) - - #set assigned [lindex $leveldata {*}$subindices] - if {[llength $subindices] == 1} { - append script \n "# index_operation listindex" \n - lappend INDEX_OPERATIONS listindex - } else { - append script \n "# index_operation listindex-nested" \n - lappend INDEX_OPERATIONS listindex-nested - } - append script \n [tstr -return string -allowcommands { - if {[catch {lindex $leveldata ${$subindices}} leveldata]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } - }] - # -- --- --- - #append script \n $returnline \n - append script [tstr -return string $return_template] - return $script - # -- --- --- - } - if {[string match @@* $selector]} { - #part following a double @ is dict key possibly with forward-slash separators for subpath access e.g @@key/subkey/etc - set rawkeylist [split $selector /] ;#first key retains @@ - may be just '@@' - set keypath [string range $selector 2 end] - set keylist [split $keypath /] - lappend INDEX_OPERATIONS dict_path - if {([lindex $rawkeylist 0] ne "@@") && ([lsearch $keylist @*] == -1) && ([lsearch $keylist #*] == -1) && ([lsearch $keylist %*] == -1)} { - #pure keylist for dict - process in one go - #dict exists will return 0 if not a valid dict. - # is equivalent to {*}keylist when substituted - append script \n [tstr -return string -allowcommands { - if {[dict exists $leveldata ${$keylist}]} { - set leveldata [dict get $leveldata ${$keylist}] - } else { - #set action ?mismatch-dict-key-not-found - ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} - } - }] - append script [tstr -return string $return_template] - return $script - # -- --- --- - } - #else - #compound keylist e.g x@@data/@0/1 or x@@/a (combined dict/list access) - #process level by level - } - - - - set i_keyindex 0 - append script \n {set i_keyindex 0} - #todo - check performance impact of catches around list and dict operations - consider single catch around destructure and less specific match error info? - foreach index $subindices { - #set index_operation "unspecified" - set level_script_complete 0 ;#instead of break - as we can't use data to determine break when building script - set SUBPATH [join [lrange $subindices 0 $i_keyindex] /] - append script \n "# ------- START index:$index subpath:$SUBPATH ------" - set lhs $index - append script \n "set lhs {$index}" - - set assigned "" - append script \n {set assigned ""} - - #got_not shouldn't need to be in script - set get_not 0 - if {[tcl::string::index $index 0] eq "!"} { - append script \n {#get_not is true e.g !0-end-1 !end-4-end-2 !0 !@0 !@@key} - set index [tcl::string::range $index 1 end] - set get_not 1 - } - - # do_bounds_check shouldn't need to be in script - set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. - #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. - #append script \n {set do_boundscheck 0} - switch -exact -- $index { - # - @# { - #list length - set active_key_type "list" - if {$get_not} { - lappend INDEX_OPERATIONS not-list - append script \n {# set active_key_type "list" index_operation: not-list} - append script \n { - if {[catch {llength $leveldata}]} { - #not a list - not-length is true - set assigned 1 - } else { - #is a list - not-length is false - set assigned 0 - } - } - } else { - lappend INDEX_OPERATIONS list-length - append script \n {# set active_key_type "list" index_operation: list-length} - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} assigned]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } - }] - } - set level_script_complete 1 - } - ## { - #dict size - set active_key_type "dict" - if {$get_not} { - lappend INDEX_OPERATIONS not-dict - append script \n {# set active_key_type "dict" index_operation: not-dict} - append script \n { - if {[catch {dict size $leveldata}]} { - set assigned 1 ;#not a dict - not-size is true - } else { - set assigned 0 ;#is a dict - not-size is false - } - } - } else { - lappend INDEX_OPERATIONS dict-size - append script \n {# set active_key_type "dict" index_operation: dict-size} - append script \n [tstr -return string -allowcommands { - if {[catch {dict size $leveldata} assigned]} { - #set action ?mismatch-not-a-dict - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } - }] - } - set level_script_complete 1 - } - %# { - set active_key_type "string" - if {$get_not} { - error "!%# not string length is not supported" - } - #string length - REVIEW - - lappend INDEX_OPERATIONS string-length - append script \n {# set active_key_type "" index_operation: string-length} - append script \n {set assigned [string length $leveldata]} - set level_script_complete 1 - } - %%# { - #experimental - set active_key_type "string" - if {$get_not} { - error "!%%# not string length is not supported" - } - #string length - REVIEW - - lappend INDEX_OPERATIONS ansistring-length - append script \n {# set active_key_type "" index_operation: ansistring-length} - append script \n {set assigned [ansistring length $leveldata]} - set level_script_complete 1 - } - %str { - set active_key_type "string" - if {$get_not} { - error "!%str - not string-get is not supported" - } - lappend INDEX_OPERATIONS string-get - append script \n {# set active_key_type "" index_operation: string-get} - append script \n {set assigned $leveldata} - set level_script_complete 1 - } - %sp { - #experimental - set active_key_type "string" - if {$get_not} { - error "!%sp - not string-space is not supported" - } - lappend INDEX_OPERATIONS string-space - append script \n {# set active_key_type "" index_operation: string-space} - append script \n {set assigned " "} - set level_script_complete 1 - } - %empty { - #experimental - set active_key_type "string" - if {$get_not} { - error "!%empty - not string-empty is not supported" - } - lappend INDEX_OPERATIONS string-empty - append script \n {# set active_key_type "" index_operation: string-empty} - append script \n {set assigned ""} - set level_script_complete 1 - } - @words { - set active_key_type "string" - if {$get_not} { - error "!%words - not list-words-from-string is not supported" - } - lappend INDEX_OPERATIONS list-words-from-string - append script \n {# set active_key_type "" index_operation: list-words-from-string} - append script \n {set assigned [regexp -inline -all {\S+} $leveldata]} - set level_script_complete 1 - } - @chars { - #experimental - leading character based on result not input(?) - #input type is string - but output is list - set active_key_type "list" - if {$get_not} { - error "!%chars - not list-chars-from-string is not supported" - } - lappend INDEX_OPERATIONS list-from_chars - append script \n {# set active_key_type "" index_operation: list-chars-from-string} - append script \n {set assigned [split $leveldata ""]} - set level_script_complete 1 - } - @join { - #experimental - flatten one level of list - #join without arg - output is list - set active_key_type "string" - if {$get_not} { - error "!@join - not list-join-list is not supported" - } - lappend INDEX_OPERATIONS list-join-list - append script \n {# set active_key_type "" index_operation: list-join-list} - append script \n {set assigned [join $leveldata]} - set level_script_complete 1 - } - %join { - #experimental - #input type is list - but output is string - set active_key_type "string" - if {$get_not} { - error "!%join - not string-join-list is not supported" - } - lappend INDEX_OPERATIONS string-join-list - append script \n {# set active_key_type "" index_operation: string-join-list} - append script \n {set assigned [join $leveldata ""]} - set level_script_complete 1 - } - %ansiview { - set active_key_type "string" - if {$get_not} { - error "!%# not string-ansiview is not supported" - } - lappend INDEX_OPERATIONS string-ansiview - append script \n {# set active_key_type "" index_operation: string-ansiview} - append script \n {set assigned [ansistring VIEW $leveldata]} - set level_script_complete 1 - } - %ansiviewstyle { - set active_key_type "string" - if {$get_not} { - error "!%# not string-ansiviewstyle is not supported" - } - lappend INDEX_OPERATIONS string-ansiviewstyle - append script \n {# set active_key_type "" index_operation: string-ansiviewstyle} - append script \n {set assigned [ansistring VIEWSTYLE $leveldata]} - set level_script_complete 1 - } - @ { - #as this is a stateful list next index operation - we use not (!@) to mean there is no element at the next index (instead of returning the complement ie all elements except next) - #This is in contrast to other not operations on indices e.g /!2 which returns all elements except that at index 2 - - - #append script \n {puts stderr [uplevel 1 [list info vars]]} - - #NOTE: - #v_list_idx in context of _multi_bind_result - #we call destructure_func from _mult_bind_result which in turn calls the proc (or the script on first run) - append script \n {upvar 2 v_list_idx v_list_idx} - - set active_key_type "list" - append script \n {# set active_key_type "list" index_operation: list-get-next} - #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey - #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 - #while x@,y@.= is reasonably handy - especially for args e.g $len} { - set assigned 1 - } else { - set assigned 0 - } - }] - - } else { - lappend INDEX_OPERATIONS get-next - append script \n [tstr -return string -allowcommands { - set index [expr {[incr v_list_idx(@)]-1}] - - if {[catch {llength $leveldata} len]} { - #set action ?mismatch-not-a-list - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } elseif {$index+1 > $len} { - #set action ?mismatch-list-index-out-of-range - ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} - } else { - set assigned [lindex $leveldata $index] - } - }] - } - set level_script_complete 1 - } - @* { - set active_key_type "list" - if {$get_not} { - lappend INDEX_OPERATIONS list-is-empty - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } elseif {$len == 0} { - set assigned 1 ;#list is empty - } else { - set assigned 0 - } - }] - } else { - lappend INDEX_OPERATIONS list-get-all - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } else { - set assigned [lrange $leveldata 0 end] - } - }] - } - set level_script_complete 1 - } - @@ { - #stateful: tracking of index using v_dict_idx - set active_key_type "dict" - lappend INDEX_OPERATIONS get-next-value - append script \n {# set active_key_type "dict" index_operation: get-next-value} - append script \n {upvar v_dict_idx v_dict_idx} ;#review! - - #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc - #x@@ = a {x y} - #x@@/@0 = a - #x@@/@1 = x y - #x@@/a = a {x y} - # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. - # (note that @@ @?@ @??@ form different subpaths - so the ? & ?? versions can be used to test match prior to @@ without affecting the index) - #review - might be more useful if they shared an index ? - # It is analogous to v1@,v2@ for lists. - # @pairs is more useful for repeated operations - - - set indent " " - set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { - if {($keyindex + 1) <= $dsize} { - set k [lindex [dict keys $leveldata] $keyindex] - set assigned [list $k [dict get $leveldata $k]] - } else { - ${[tstr -ret string $tpl_return_mismatch_dict_index_out_of_range]} - } - }] - - set assignment_script [tstr -ret string -allowcommands $assignment_script] - - append script [tstr -return string -allowcommands { - if {[catch {dict size $leveldata} dsize]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } else { - set next_this_level [incr v_dict_idx(${$SUBPATH})] - set keyindex [expr {$next_this_level -1}] - ${$assignment_script} - } - }] - set level_script_complete 1 - } - @?@ { - #stateful: tracking of index using v_dict_idx - set active_key_type "dict" - lappend INDEX_OPERATIONS get?-next-value - append script \n {# set active_key_type "dict" index_operation: get?-next-value} - append script \n {upvar v_dict_idx v_dict_idx} ;#review! - set indent " " - set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { - if {($keyindex + 1) <= $dsize} { - set k [lindex [dict keys $leveldata] $keyindex] - set assigned [dict get $leveldata $k] - } else { - set assigned [list] - } - }] - append script [tstr -return string -allowcommands { - if {[catch {dict size $leveldata} dsize]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } else { - set next_this_level [incr v_dict_idx(${$SUBPATH})] - set keyindex [expr {$next_this_level -1}] - ${$assignment_script} - } - }] - set level_script_complete 1 - } - @??@ { - set active_key_type "dict" - lappend INDEX_OPERATIONS get?-next-pair - append script \n {# set active_key_type "dict" index_operation: get?-next-pair} - append script \n {upvar v_dict_idx v_dict_idx} ;#review! - set indent " " - set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent" ] { - if {($keyindex + 1) <= $dsize} { - set k [lindex [dict keys $leveldata] $keyindex] - set assigned [list $k [dict get $leveldata $k]] - } else { - set assigned [list] - } - }] - append script [tstr -return string -allowcommands { - if {[catch {dict size $leveldata} dsize]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } else { - set next_this_level [incr v_dict_idx(${$SUBPATH})] - set keyindex [expr {$next_this_level -1}] - ${$assignment_script} - } - }] - set level_script_complete 1 - } - @vv@ - @VV@ - @kk@ - @KK@ { - error "unsupported index $index" - } - default { - - #assert rules for values within @@ - #glob search is done only if there is at least one * within @@ - #if there is at least one ? within @@ - then a non match will not raise an error (quiet) - - #single or no char between @@: - #lookup/search is based on key - return is values - - #double char within @@: - #anything with a dot returns k v pairs e.g @k.@ @v.@ @..@ - #anything that is a duplicate returns k v pairs e.g @kk@ @vv@ @**@ - #anything with a letter and a star returns the type of the letter, and the search is based on the position of the star where posn 1 is for key, posn 2 is for value - #e.g @k*@ returns keys - search on values - #e.g @*k@ returns keys - search on keys - #e.g @v*@ returns values - search on values - #e.g @*v@ returns values - search on keys - - switch -glob -- $index { - @@* { - #exact key match - return value - #noisy get value - complain if key non-existent - #doesn't complain if not a dict - because we use 'tcl::dict::exists' which will return false without error even if the value isn't dict-shaped - set active_key_type "dict" - set key [string range $index 2 end] - if {$get_not} { - lappend INDEX_OPERATIONS exactkey-get-value-not - #review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here - #this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key - append script \n [tstr -return string -allowcommands { - # set active_key_type "dict" index_operation: exactkey-get-value-not - if {[dict exists $leveldata ${$key}]} { - set assigned [dict values [dict remove $leveldata ${$key}]] - } else { - #set action ?mismatch-dict-key-not-found - ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} - } - }] - - } else { - lappend INDEX_OPERATIONS exactkey-get-value - append script \n [tstr -return string -allowcommands { - # set active_key_type "dict index_operation: exactkey-get-value" - if {[dict exists $leveldata ${$key}]} { - set assigned [dict get $leveldata ${$key}] - } else { - #set action ?mismatch-dict-key-not-found - ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} - } - }] - } - set level_script_complete 1 - } - {@\?@*} { - #exact key match - quiet get value - #silent empty result if non-existent key - silence when non-existent key also if using not-@?@badkey which will just return whole dict - #note - dict remove will raise error on non-dict-shaped value whilst dict exists will not - set active_key_type "dict" - set key [string range $index 3 end] - if {$get_not} { - lappend INDEX_OPERATIONS exactkey?-get-value-not - append script \n [tstr -return string -allowcommands { - # set active_key_type "dict" index_operation: exactkey?-get-value-not - if {[catch {dict size $leveldata}]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } - set assigned [dict values [dict remove $leveldata ${$key}]] - }] - - } else { - lappend INDEX_OPERATIONS exactkey?-get-value - #dict exists test is safe - no need for catch - append script \n [string map [list $key] { - # set active_key_type "dict" index_operation: exactkey?-get-value - if {[dict exists $leveldata ]} { - set assigned [dict get $leveldata ] - } else { - set assigned [dict create] - } - }] - } - set level_script_complete 1 - } - {@\?\?@*} { - #quiet get pairs - #this is silent too.. so how do we do a checked return of dict key+val? - set active_key_type "dict" - set key [string range $index 4 end] - if {$get_not} { - lappend INDEX_OPERATIONS exactkey?-get-pair-not - append script \n [tstr -return string -allowcommands { - # set active_key_type "dict" index_operation: exactkey?-get-pair-not - if {[catch {dict size $leveldata}]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } - set assigned [dict remove $leveldata ${$key}] - }] - } else { - lappend INDEX_OPERATIONS exactkey?-get-pair - append script \n [string map [list $key] { - # set active_key_type "dict" index_operation: exactkey?-get-pair - if {[dict exists $leveldata ]} { - set assigned [dict create [dict get $leveldata ]] - } else { - set assigned [dict create] - } - }] - } - set level_script_complete 1 - } - @..@* - @kk@* - @KK@* { - #noisy get pairs by key - set active_key_type "dict" - set key [string range $index 4 end] - if {$get_not} { - lappend INDEX_OPERATIONS exactkey-get-pairs-not - #review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here - #this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key - append script \n [tstr -return string -allowcommands { - # set active_key_type "dict" index_operation: exactkey-get-pairs-not - if {[dict exists $leveldata ${$key}]} { - set assigned [tcl::dict::remove $leveldata ${$key}] - } else { - ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} - } - }] - - } else { - lappend INDEX_OPERATIONS exactkey-get-pairs - append script \n [tstr -return string -allowcommands { - # set active_key_type "dict index_operation: exactkey-get-pairs" - if {[dict exists $leveldata ${$key}]} { - tcl::dict::set assigned ${$key} [tcl::dict::get $leveldata ${$key}] - } else { - ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} - } - }] - } - set level_script_complete 1 - - } - @vv@* - @VV@* { - #noisy(?) get pairs by exact value - #return mismatch on non-match even when not- specified - set active_key_type "dict" - set keyglob [string range $index 4 end] - set active_key_type "dict" - set key [string range $index 4 end] - if {$get_not} { - #review - for consistency we are reporting a mismatch when the antikey being looked up doesn't exist - #The utility of this is debatable - lappend INDEX_OPERATIONS exactvalue-get-pairs-not - append script \n [tstr -return string -allowcommands { - # set active_key_type "dict" index_operation: exactvalue-get-pairs-not - if {[catch {dict size $leveldata}]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } - set nonmatches [dict create] - tcl::dict::for {k v} $leveldata { - if {![string equal ${$key} $v]} { - dict set nonmatches $k $v - } - } - - if {[dict size $nonmatches] < [dict size $leveldata]} { - #our key matched something - set assigned $nonmatches - } else { - #our key didn't match anything - don't return the nonmatches - #set action ?mismatch-dict-key-not-found - ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} - } - }] - - } else { - lappend INDEX_OPERATIONS exactvalue-get-pairs - append script \n [tstr -return string -allowcommands { - # set active_key_type "dict index_operation: exactvalue-get-pairs-not" - if {[catch {dict size $leveldata}]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } - set matches [list] - tcl::dict::for {k v} $leveldata { - if {[string equal ${$key} $v]} { - lappend matches $k $v - } - } - if {[llength $matches]} { - set assigned $matches - } else { - #set action ?mismatch-dict-key-not-found - ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} - } - }] - } - set level_script_complete 1 - - } - {@\*@*} - {@\*v@*} - {@\*V@*} { - #dict key glob - return values only - set active_key_type "dict" - if {[string match {@\*@*} $index]} { - set keyglob [string range $index 3 end] - } else { - #vV - set keyglob [string range $index 4 end] - } - #if $keyglob eq "" - needs to query for dict key that is empty string. - if {$get_not} { - lappend INDEX_OPERATIONS globkey-get-values-not - append script \n [tstr -return string -allowcommands { - if {[catch {dict size $leveldata}]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } - # set active_key_type "dict" index_operation: globkey-get-values-not - set matched [dict keys $leveldata {${$keyglob}}] - set assigned [dict values [dict remove $leveldata {*}$matched]] - }] - - } else { - lappend INDEX_OPERATIONS globkey-get-values - append script \n [tstr -return string -allowcommands { - # set active_key_type "dict" index_operation: globkey-get-values - if {[catch {dict size $leveldata}]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } - set matched [dict keys $leveldata {${$keyglob}}] - set assigned [list] - foreach m $matched { - lappend assigned [dict get $leveldata $m] - } - }] - } - set level_script_complete 1 - - } - {@\*.@*} { - #dict key glob - return pairs - set active_key_type "dict" - set keyglob [string range $index 4 end] - append script [tstr -return string -allowcommands { - if {[catch {dict size $leveldata}]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } - }] - if {$get_not} { - lappend INDEX_OPERATIONS globkey-get-pairs-not - append script \n [string map [list $keyglob] { - # set active_key_type "dict" index_operation: globkey-get-pairs-not - set matched [dict keys $leveldata {}] - set assigned [dict remove $leveldata {*}$matched] - }] - - } else { - lappend INDEX_OPERATIONS globkey-get-pairs - append script \n [string map [list $keyglob] { - # set active_key_type "dict" index_operations: globkey-get-pairs - set matched [dict keys $leveldata {}] - set assigned [dict create] - foreach m $matched { - dict set assigned $m [dict get $leveldata $m] - } - }] - } - set level_script_complete 1 - } - {@\*k@*} - {@\*K@*} { - #dict key glob - return keys - set active_key_type "dict" - set keyglob [string range $index 4 end] - append script [tstr -return string -allowcommands { - if {[catch {dict size $leveldata}]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } - }] - if {$get_not} { - lappend INDEX_OPERATIONS globkey-get-keys-not - append script \n [string map [list $keyglob] { - # set active_key_type "dict" index_operation: globkey-get-keys-not - set matched [dict keys $leveldata {}] - set assigned [dict keys [dict remove $leveldata {*}$matched]] - }] - - } else { - lappend INDEX_OPERATIONS globkey-get-keys - append script \n [string map [list $keyglob] { - # set active_key_type "dict" index_operation: globkey-get-keys - set assigned [dict keys $leveldata {}] - }] - } - set level_script_complete 1 - } - {@k\*@*} - {@K\*@*} { - #dict value glob - return keys - set active_key_type "dict" - set valglob [string range $index 4 end] - append script [tstr -return string -allowcommands { - if {[catch {dict size $leveldata}]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } - }] - if {$get_not} { - lappend INDEX_OPERATIONS globvalue-get-keys-not - append script \n [string map [list $valglob] { - # set active_key_type "dict" index_operation: globvalue-get-keys-not - set assigned [list] - tcl::dict::for {k v} $leveldata { - if {![string match {} $v]} { - lappend assigned $k - } - } - }] - } else { - lappend INDEX_OPERATIONS globvalue-get-keys - append script \n [string map [list $valglob] { - # set active_key_type "dict" index_operation: globvalue-get-keys - set assigned [list] - tcl::dict::for {k v} $leveldata { - if {[string match {} $v]} { - lappend assigned $k - } - } - }] - } - set level_script_complete 1 - } - {@.\*@*} { - #dict value glob - return pairs - set active_key_type "dict" - set valglob [string range $index 4 end] - append script [tstr -return string -allowcommands { - if {[catch {dict size $leveldata}]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } - }] - if {$get_not} { - lappend INDEX_OPERATIONS globvalue-get-pairs-not - append script \n [string map [list $valglob] { - # set active_key_type "dict" index_operation: globvalue-get-pairs-not - set assigned [dict create] - tcl::dict::for {k v} $leveldata { - if {![string match {} $v]} { - dict set assigned $k $v - } - } - }] - } else { - lappend INDEX_OPERATIONS globvalue-get-pairs - append script \n [string map [list $valglob] { - # set active_key_type "dict" index_operation: globvalue-get-pairs - set assigned [dict create] - tcl::dict::for {k v} $leveldata { - if {[string match {} $v]} { - dict set assigned $k $v - } - } - }] - } - set level_script_complete 1 - } - {@V\*@*} - {@v\*@*} { - #dict value glob - return values - set active_key_type dict - set valglob [string range $index 4 end] - append script [tstr -return string -allowcommands { - if {[catch {dict size $leveldata}]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } - }] - if {$get_not} { - lappend INDEX_OPERATIONS globvalue-get-values-not - append script \n [string map [list $valglob] { - # set active_key_type "dict" ;# index_operation: globvalue-get-values-not - set assigned [list] - tcl::dict::for {k v} $leveldata { - if {![string match {} $v]} { - lappend assigned $v - } - } - }] - - } else { - lappend INDEX_OPERATIONS globvalue-get-values - append script \n [string map [list $valglob] { - # set active_key_type "dict" ;#index_operation: globvalue-get-value - set assigned [dict values $leveldata ] - }] - } - set level_script_complete 1 - - } - {@\*\*@*} { - #dict val/key glob return pairs) - set active_key_type "dict" - set keyvalglob [string range $index 4 end] - append script [tstr -return string -allowcommands { - if {[catch {dict size $leveldata}]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } - }] - if {$get_not} { - lappend INDEX_OPERATIONS globkeyvalue-get-pairs-not - error "globkeyvalue-get-pairs-not todo" - } else { - lappend INDEX_OPERATIONS globkeyvalue-get-pairs - append script \n [string map [list $keyvalglob] { - # set active_key_type "dict" ;# index_operation: globkeyvalue-get-pairs-not - set assigned [dict create] - tcl::dict::for {k v} $leveldata { - if {[string match {} $k] || [string match {} $v]} { - dict set assigned $k $v - } - } - }] - } - set level_script_complete 1 - puts stderr "globkeyvalue-get-pairs review" - } - @* { - set active_key_type "list" - set do_bounds_check 1 - - set index [string trimleft $index @] - append script \n [string map [list $index] { - # set active_key_type "list" index_operation: ? - set index - }] - } - %* { - set active_key_type "string" - set do_bounds_check 0 - set index [string range $index 1 end] - append script \n [string map [list $index] { - # set active_key_type "string" index_operation: ? - set index - }] - } - default { - puts "destructure_func_build_body unmatched index $index" - } - } - } - } - - if {!$level_script_complete} { - - - #keyword 'pipesyntax' at beginning of error message - set listmsg "pipesyntax Unable to interpret subindex $index\n" - append listmsg "selector: '$selector'\n" - append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n" - append listmsg "Additional accepted keywords include: head tail\n" - append listmsg "Use var@@key to treat value as a dict and retrieve element at key" - - #append script \n [string map [list $listmsg] {set listmsg ""}] - - - - #we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against - #need to set a corresponding action - if {$active_key_type in [list "" "list"]} { - set active_key_type "list" - append script \n {# set active_key_type "list"} - #for pattern matching purposes - head/tail not valid on empty lists (similar to elixir) - switch -exact -- $index { - 0 { - if {$get_not} { - append script \n "# index_operation listindex-int-not" \n - lappend INDEX_OPERATIONS listindex-zero-not - set assignment_script {set assigned [lrange $leveldata 1 end]} - } else { - lappend INDEX_OPERATIONS listindex-zero - set assignment_script {set assigned [lindex $leveldata 0]} - if {$do_bounds_check} { - append script \n "# index_operation listindex-int (bounds checked)" \n - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } elseif {[llength $leveldata] == 0} { - ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} - } else { - ${$assignment_script} - } - }] - } else { - append script \n "# index_operation listindex-int" \n - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } else { - ${$assignment_script} - } - }] - } - } - } - head { - #NOTE: /@head and /head both do bounds check. This is intentional - if {$get_not} { - append script \n "# index_operation listindex-head-not" \n - lappend INDEX_OPERATIONS listindex-head-not - set assignment_script {set assigned [lrange $leveldata 1 end]} - } else { - append script \n "# index_operation listindex-head" \n - lappend INDEX_OPERATIONS listindex-head - set assignment_script {set assigned [lindex $leveldata 0]} - } - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - #set action ?mismatch-not-a-list - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } elseif {$len == 0} { - #set action ?mismatch-list-index-out-of-range-empty - ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} - } else { - #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax - ${$assignment_script} - } - }] - } - end { - if {$get_not} { - append script \n "# index_operation listindex-end-not" \n - lappend INDEX_OPERATIONS listindex-end-not - #on single element list Tcl's lrange will do what we want here and return nothing - set assignment_script {set assigned [lrange $leveldata 0 end-1]} - } else { - append script \n "# index_operation listindex-end" \n - lappend INDEX_OPERATIONS listindex-end - set assignment_script {set assigned [lindex $leveldata end]} - } - if {$do_bounds_check} { - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - #set action ?mismatch-not-a-list - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } elseif {$len == 0} { - #set action ?mismatch-list-index-out-of-range - ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} - } else { - ${$assignment_script} - } - }] - } else { - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - #set action ?mismatch-not-a-list - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } else { - ${$assignment_script} - } - }] - } - } - tail { - #NOTE: /@tail and /tail both do bounds check. This is intentional. - # - #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list - #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. - #In this way tail is different to @1-end - if {$get_not} { - append script \n "# index_operation listindex-tail-not" \n - lappend INDEX_OPERATIONS listindex-tail-not - set assignment_script {set assigned [lindex $leveldata 0]} - } else { - append script \n "# index_operation listindex-tail" \n - lappend INDEX_OPERATIONS listindex-tail - set assignment_script {set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero} - } - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - #set action ?mismatch-not-a-list - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } elseif {$len == 0} { - #set action ?mismatch-list-index-out-of-range - ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} - } else { - ${$assignment_script} - } - }] - } - anyhead { - #allow returning of head or nothing if empty list - if {$get_not} { - append script \n "# index_operation listindex-anyhead-not" \n - lappend INDEX_OPERATIONS listindex-anyhead-not - set assignment_script {set assigned [lrange $leveldata 1 end]} - } else { - append script \n "# index_operation listindex-anyhead" \n - lappend INDEX_OPERATIONS listindex-anyhead - set assignment_script {set assigned [lindex $leveldata 0]} - } - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - #set action ?mismatch-not-a-list - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } else { - ${$assignment_script} - } - }] - } - anytail { - #allow returning of tail or nothing if empty list - #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead. - if {$get_not} { - append script \n "# index_operation listindex-anytail-not" \n - lappend INDEX_OPERATIONS listindex-anytail-not - set assignment_script {set assigned [lindex $leveldata 0]} - } else { - append script \n "# index_operation listindex-anytail" \n - lappend INDEX_OPERATIONS listindex-anytail - set assignment_script {set assigned [lrange $leveldata 1 end]} - } - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - #set action ?mismatch-not-a-list - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } else { - ${$assignment_script} - } - }] - } - init { - #all but last element - same as haskell 'init' - #counterintuitively, get-notinit can therefore return first element if it is a single element list - #does bounds_check for get-not@init make sense here? maybe - review - if {$get_not} { - append script \n "# index_operation listindex-init-not" \n - lappend INDEX_OPERATIONS listindex-init-not - set assignment_script {set assigned [lindex $leveldata end]} - } else { - append script \n "# index_operation listindex-init" \n - lappend INDEX_OPERATIONS listindex-init - set assignment_script {set assigned [lrange $leveldata 0 end-1]} - } - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - #set action ?mismatch-not-a-list - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } else { - ${$assignment_script} - } - }] - } - list { - #get_not? - #allow returning of entire list even if empty - if {$get_not} { - lappend INDEX_OPERATIONS list-getall-not - set assignment_script {set assigned {}} - } else { - lappend INDEX_OPERATIONS list-getall - set assignment_script {set assigned $leveldata} - } - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - #set action ?mismatch-not-a-list - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } else { - ${$assignment_script} - } - }] - } - raw { - #get_not - return nothing?? - #no list checking.. - if {$get_not} { - lappend INDEX_OPERATIONS getraw-not - append script \n {set assigned {}} - } else { - lappend INDEX_OPERATIONS getraw - append script \n {set assigned $leveldata} - } - } - keys { - #@get_not?? - #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements - if {$get_not} { - lappend INDEX_OPERATIONS list-getkeys-not - set assignment_script {set assigned [dict values $leveldata]} ;#not-keys is equivalent to values - } else { - lappend INDEX_OPERATIONS list-getkeys - set assignment_script {set assigned [dict keys $leveldata]} - } - append script \n [tstr -return string -allowcommands { - if {[catch {dict size $leveldata} dsize]} { - #set action ?mismatch-not-a-dict - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } else { - ${$assignment_script} - } - }] - } - values { - #get_not ?? - #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements - if {$get_not} { - lappend INDEX_OPERATIONS list-getvalues-not - set assignment_script {set assigned [dict keys $leveldata]} ;#not-values is equivalent to keys - } else { - lappend INDEX_OPERATIONS list-getvalues - set assignment_script {set assigned [dict values $leveldata]} - } - append script \n [tstr -return string -allowcommands { - if {[catch {dict size $leveldata} dsize]} { - #set action ?mismatch-not-a-dict - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } else { - ${$assignment_script} - } - }] - } - pairs { - #get_not ?? - if {$get_not} { - #review - return empty list instead like not-list and not-raw? - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector not-pairs_not_supported] - } else { - lappend INDEX_OPERATIONS list-getpairs - } - append script \n [tstr -return string -allowcommands { - if {[catch {dict size $leveldata} dsize]} { - #set action ?mismatch-not-a-dict - ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} - } else { - set pairs [list] - tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]} - set assigned [lindex [list $pairs [unset pairs]] 0] - } - }] - } - default { - if {[regexp {[?*]} $index]} { - if {$get_not} { - lappend INDEX_OPERATIONS listsearch-not - set assign_script [string map [list $index] { - set assigned [lsearch -all -inline -not $leveldata ] - }] - } else { - lappend INDEX_OPERATIONS listsearch - set assign_script [string map [list $index] { - set assigned [lsearch -all -inline $leveldata ] - }] - } - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } else { - ${$assign_script} - } - }] - } elseif {[string is integer -strict $index]} { - if {$get_not} { - lappend INDEX_OPERATIONS listindex-not - set assign_script [string map [list $index] { - #not- was specified (already handled not-0) - set assigned [lreplace $leveldata ] - }] - } else { - lappend INDEX_OPERATIONS listindex - set assign_script [string map [list $index] {set assigned [lindex $leveldata ]}] - } - - if {$do_bounds_check} { - if {$index < 0} { - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector index_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] - } - set max [expr {$index + 1}] - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - #set action ?mismatch-not-a-list - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } else { - # bounds_check due to @ directly specified in original index section - if {${$max} > $len} { - #set action ?mismatch-list-index-out-of-range - ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} - } else { - ${$assign_script} - } - } - }] - } else { - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - #set action ?mismatch-not-a-list - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } else { - ${$assign_script} - } - }] - } - } elseif {[string first "end" $index] >=0} { - if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { - - if {$get_not} { - lappend INDEX_OPERATIONS listindex-endoffset-not - set assign_script [string map [list $index] { - #not- was specified (already handled not-0) - set assigned [lreplace $leveldata ] - }] - } else { - lappend INDEX_OPERATIONS listindex-endoffset - set assign_script [string map [list $index ] {set assigned [lindex $leveldata ]}] - } - - if {$do_bounds_check} { - #tstr won't add braces - so the ${$endspec} value inserted in the expr will remain unbraced as required in this case. - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - set action ?mismatch-not-a-list - } else { - #bounds-check is true - #leave the - from the end- as part of the offset - set offset [expr ${$endspec}] ;#don't brace! - if {($offset > 0 || abs($offset) >= $len)} { - #set action ?mismatch-list-index-out-of-range - ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} - } else { - ${$assign_script} - } - } - }] - } else { - append script \n [tstr -ret string -allowcommands { - if {[catch {llength $leveldata} len]} { - #set action ?mismatch-not-a-list - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } else { - ${$assign_script} - } - }] - } - - } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { - if {$get_not} { - lappend INDEX_OPERATIONS list-range-not - set assign_script [string map [list $start $end ] { - #not- was specified (already handled not-0) - set assigned [lreplace $leveldata ] - }] - } else { - lappend INDEX_OPERATIONS list-range - set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}] - } - - append script \n [tstr -ret string -allowcommands { - if {[catch {llength $leveldata} len]} { - #set action ?mismatch-not-a-list - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } - }] - - if {$do_bounds_check} { - if {[string is integer -strict $start]} { - if {$start < 0} { - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector start_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] - } - append script \n [tstr -return string -allowcommands { - set start ${$start} - if {$start+1 > $len} { - #set action ?mismatch-list-index-out-of-range - ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} - } - }] - } elseif {$start eq "end"} { - #noop - } else { - set startoffset [string range $start 3 end] ;#include the - from end- - set startoffset [expr $startoffset] ;#don't brace! - if {$startoffset > 0} { - #e.g end+1 - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] - - } - append script \n [tstr -return string -allowcommands { - set startoffset ${$startoffset} - if {abs($startoffset) >= $len} { - #set action ?mismatch-list-index-out-of-range - ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} - } - }] - } - if {[string is integer -strict $end]} { - if {$end < 0} { - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] - } - append script \n [tstr -return string -allowcommands { - set end ${$end} - if {$end+1 > $len} { - #set action ?mismatch-list-index-out-of-range - ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} - } - }] - } elseif {$end eq "end"} { - #noop - } else { - set endoffset [string range $end 3 end] ;#include the - from end- - - set endoffset [expr $endoffset] ;#don't brace! - if {$endoffset > 0} { - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] - } - append script \n [tstr -return string -allowcommands { - set endoffset ${$endoffset} - if {abs($endoffset) >= $len} { - #set action ?mismatch-list-index-out-of-range - ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} - } - }] - } - } - - append script \n [string map [list $assign_script] { - if {![string match ?mismatch-* $action]} { - - } - }] - - } else { - #fail now - no need for script - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] - } - } elseif {[string first - $index] > 0} { - #e.g @1-3 gets here - #JMN - if {$get_not} { - lappend INDEX_OPERATIONS list-range-not - } else { - lappend INDEX_OPERATIONS list-range - } - - append script \n [tstr -return string -allowcommands { - if {[catch {llength $leveldata} len]} { - #set action ?mismatch-not-a-list - ${[tstr -ret string $tpl_return_mismatch_not_a_list]} - } - }] - - #handle pure int-int ranges separately - set testindex [string map [list - "" + ""] $index] - if {[string is digit -strict $testindex]} { - #don't worry about leading - negative value for indices not valid anyway - set parts [split $index -] - if {[llength $parts] != 2} { - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] - } - lassign $parts start end - - #review - Tcl lrange just returns nothing silently. - #if we don't intend to implement reverse indexing - we should probably not emit an error - if {$start > $end} { - puts stderr "pipesyntax for selector $selector error - reverse index unimplemented" - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] - } - if {$do_bounds_check} { - #append script [string map [list $start $end] { - # set start - # set end - # if {$start+1 > $len || $end+1 > $len} { - # set action ?mismatch-list-index-out-of-range - # } - #}] - #set eplusone [expr {$end+1}] - append script [tstr -return string -allowcommands { - if {$len < ${[expr {$end+1}]}} { - set action ?mismatch-list-index-out-of-range - ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} - } - }] - } - - - if {$get_not} { - set assign_script [string map [list $start $end] { - #not- was specified (already handled not-0) - set assigned [lreplace $leveldata ] - }] - } else { - set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}] - } - - - } else { - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] - } - - append script \n [string map [list $assign_script] { - if {![string match ?mismatch-* $action]} { - - } - }] - - } else { - #keyword 'pipesyntax' at beginning of error message - #pipesyntax error - no need to even build script - can fail now - error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] - } - } - } - } elseif {$active_key_type eq "string"} { - if {[string match *-* $index]} { - lappend INDEX_OPERATIONS string-range - set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$} - #todo - support more complex indices: 0-end-1 etc - - lassign [split $index -] a b - append script \n [tstr -return string -allowcommands { - # set active_key_type "string" - set assigned [string range $leveldata ${$a} ${$b}] - }] - - } else { - if {$index eq "*"} { - lappend INDEX_OPERATIONS string-all - append script \n [tstr -return string -allowcommands { - # set active_key_type "string" - set assigned $leveldata - }] - } elseif {[regexp {[?*]} $index]} { - lappend INDEX_OPERATIONS string-globmatch - append script \n [tstr -return string -allowcommands { - # set active_key_type "string" - if {[string match $index $leveldata]} { - set assigned $leveldata - } else { - set assigned "" - } - }] - } else { - lappend INDEX_OPERATIONS string-index - append script \n [tstr -return string -allowcommands { - # set active_key_type "string" - set assigned [string index $leveldata ${$index}] - }] - } - } - - } else { - #treat as dict key - if {$get_not} { - #dict remove can accept non-existent keys.. review do we require not-@?@key to get silence? - append script \n [tstr -return string { - set assigned [dict remove $leveldata ${$index}] - }] - } else { - append script \n [tstr -return string -allowcommands { - # set active_key_type "dict" - if {[dict exists $leveldata {${$index}}]} { - set assigned [dict get $leveldata {${$index}}] - } else { - set action ?mismatch-dict-key-not-found - ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} - } - }] - } - - } - - - } ;# end if $level_script_complete - - - append script \n { - set leveldata $assigned - } - incr i_keyindex - append script \n "# ------- END index $index ------" - } ;# end foreach - - - - #puts stdout "----> destructure rep leveldata: [rep $leveldata]" - #puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]" - - #maintain key order - caller unpacks using lassign - #append script \n {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} - append script \n [tstr -return string $return_template] \n - return $script - } - - - - - #called from match_assign/know_dot_assign for lhs of assignment - uplevel 2 to caller's level - #called from match_assign/know_dot_assign for rhs pipelined vars - uplevel 1 to write vars only in 'apply' scope - #return a dict with keys result, setvars, unsetvars - #TODO - implement cross-binding (as opposed to overwrite/reassignment) when a var appears multiple times in a pattern/multivar - #e.g x@0,x@1 will only match if value at positions 0 & 1 is the same (a form of auto-pinning?) - #e.g x,x@0 will only match a single element list - #todo blocking or - p1|p2 if p1 matches - return p1 and continue pipeline - immediately return p2 if p1 didn't match. (ie p2 not forwarded in pipeline) - # non-blocking or - p1||p2 if p1 matches - return p1 and continue pipeline - else match p2 and continue pipeline - proc _multi_bind_result {multivar data args} { - #puts stdout "---- _multi_bind_result multivar:'$multivar' data:'$data' options:'$args'" - #'ismatch' must always be first element of dict - as we dispatch on ismatch 0 or ismatch 1 - if {![string length $multivar]} { - #treat the absence of a pattern as a match to anything - #JMN2 - changed to list based destructuring - return [dict create ismatch 1 result $data setvars {} script {}] - #return [dict create ismatch 1 result [list $data] setvars {} script {}] - } - set returndict [dict create ismatch 0 result "" setvars {}] - set script "" - - set defaults [list -unset 0 -levelup 2 -mismatchinfo 1 -script 0] - set opts [dict merge $defaults $args] - set unset [dict get $opts -unset] - set lvlup [dict get $opts -levelup] - set get_mismatchinfo [dict get $opts -mismatchinfo] - - - - #first classify into var_returntype of either "pipeline" or "segment" - #segment returntype is indicated by leading % - - set varinfo [punk::pipe::lib::_var_classify $multivar] - set var_names [dict get $varinfo var_names] - set var_class [dict get $varinfo var_class] - set varspecs_trimmed [dict get $varinfo varspecs_trimmed] - - set var_actions [list] - set expected_values [list] - #e.g {a = abc} {b set ""} - foreach classinfo $var_class vname $var_names { - lassign [lindex $classinfo 0] v - lappend var_actions [list $v "" ""] ;#varactions keeps original lhs - not trimmed version - lappend expected_values [list var $vname spec $v info - lhs - rhs -] ;#code looks for 'info -' to see if changed from default - } - - #puts stdout "var_actions: $var_actions" - #puts stdout "expected_values: $expected_values" - - - #puts stdout "\n var_class: $var_class\n" - # e.g {{x {}} 0} {{y @0} 0} {{'ok @0} 1} {{^v @@key} 2} - - #set varspecs_trimmed [lmap varinfo $var_class {expr {([lindex $varinfo 1] > 0) ? [list [string range [lindex $varinfo 0 0] 1 end] [lindex $varinfo 0 1]] : [lindex $varinfo 0]}}] - #puts stdout "\n varspecs_trimmed: $varspecs_trimmed\n" - - - #var names (possibly empty portion to the left of ) - #debug.punk.pipe.var "varnames: $var_names" 4 - - set v_list_idx(@) 0 ;#for spec with single @ only - set v_dict_idx(@@) 0 ;#for spec with @@ only - - #jn - - #member lists of returndict which will be appended to in the initial value-retrieving loop - set returndict_setvars [dict get $returndict setvars] - - set assigned_values [list] - - - #varname action value - where value is value to be set if action is set - #actions: - # "" unconfigured - assert none remain unconfigured at end - # noop no-change - # matchvar-set name is a var to be matched - # matchatom-set names is an atom to be matched - # matchglob-set - # set - # question mark versions are temporary - awaiting a check of action vs var_class - # e.g ?set may be changed to matchvar or matchatom or set - - - debug.punk.pipe.var {initial map expected_values: $expected_values} 5 - - set returnval "" - set i 0 - #assertion i incremented at each continue and at each end of loop - at end i == list length + 1 - #always use 'assigned' var in each loop - # (for consistency and to assist with returnval) - # ^var means a pinned variable - compare value of $var to rhs - don't assign - # - # In this loop we don't set variables - but assign an action entry in var_actions - all with leading question mark. - # as well as adding the data values to the var_actions list - # - # TODO! we may (commonly) encounter same vkey in the pattern - no need to reparse and re-fetch from data! - set vkeys_seen [list] - foreach v_and_key $varspecs_trimmed { - set vspec [join $v_and_key ""] - lassign $v_and_key v vkey - - set assigned "" - #The binding spec begins at first @ or # or / - - #set firstq [string first "'" $vspec] - #set v [lindex $var_names $i] - #if v contains any * and/or ? - then it is a glob match - not a varname - - lassign [destructure_func $vkey $data] _assigned assigned _action matchaction _lhs lhs _rhs rhs - if {$matchaction eq "?match"} { - set matchaction "?set" - } - lset var_actions $i 1 $matchaction - lset var_actions $i 2 $assigned - - #update the setvars/unsetvars elements - if {[string length $v]} { - dict set returndict_setvars $v $assigned - } - - #JMN2 - #special case expansion for empty varspec (e.g , or ,,) - #if {$vspec eq ""} { - # lappend assigned_values {*}$assigned - #} else { - lappend assigned_values $assigned - #} - incr i - } - - #todo - fix! this isn't the actual tclvars that were set! - dict set returndict setvars $returndict_setvars - - #assigned_values is the ordered list of source elements in the data (rhs) as extracted by each position-spec - #For booleans the final val may later be normalised to 0 or 1 - - - #assertion all var_actions were set with leading question mark - #perform assignments only if matched ok - - - #0 - novar - #1 - atom ' - #2 - pin ^ - #3 - boolean & - #4 - integer - #5 - double - #6 - var - #7 - glob (no classifier and contains * or ?) - if 0 { - debug.punk.pipe.var {VAR_CLASS: $var_class} 5 - debug.punk.pipe.var {VARACTIONS: $var_actions} 5 - debug.punk.pipe.var {VARSPECS_TRIMMED: $varspecs_trimmed} 5 - - debug.punk.pipe.var {atoms: [lsearch -all -inline -index 1 $var_class 1]} 5 - debug.punk.pipe.var {pins: [lsearch -all -inline -index 1 $var_class 2]} 5 - debug.punk.pipe.var {bools: [lsearch -all -inline -index 1 $var_class 3]} 5 - debug.punk.pipe.var {ints: [lsearch -all -inline -index 1 $var_class 4]} 5 - debug.punk.pipe.var {doubles: [lsearch -all -inline -index 1 $var_class 5]} 5 - debug.punk.pipe.var {vars: [lsearch -all -inline -index 1 $var_class 6]} 5 - debug.punk.pipe.var {globs: [lsearch -all -inline -index 1 $var_class 7]} 5 - } - - set match_state [lrepeat [llength $var_names] ?] - unset -nocomplain v - unset -nocomplain nm - set mismatched [list] - set i 0 - #todo - stop at first mismatch - for pattern matching (especially pipecase - we don't want to waste time reading vars if we already have a mismatch earlier in the pattern) - foreach va $var_actions { - #val comes from -assigned - lassign $va lhsspec act val ;#lhsspec is the full value source for LHS ie the full atom/number/varspec e.g for pattern ^var@@key/@0 it is "^var" - set varname [lindex $var_names $i] - - if {[string match "?mismatch*" $act]} { - #already determined a mismatch - e.g list or dict key not present - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info mismatch lhs ? rhs $val] - break - } - - - set class_key [lindex $var_class $i 1] - lassign {0 0 0 0 0 0 0 0 0 0} isatom ispin isbool isint isdouble isvar isglob isnumeric isgreaterthan islessthan - foreach ck $class_key { - switch -- $ck { - 1 {set isatom 1} - 2 {set ispin 1} - 3 {set isbool 1} - 4 {set isint 1} - 5 {set isdouble 1} - 6 {set isvar 1} - 7 {set isglob 1} - 8 {set isnumeric 1} - 9 {set isgreaterthan 1} - 10 {set islessthan 1} - } - } - - - #set isatom [expr {$class_key == 1}] - #set ispin [expr {2 in $class_key}] - #set isbool [expr {3 in $class_key}] - #set isint [expr {4 in $class_key}] - #set isdouble [expr {5 in $class_key}] - #set isvar [expr {$class_key == 6}] - #set isglob [expr {7 in $class_key}] - #set isnumeric [expr {8 in $class_key}] ;#force numeric comparison (only if # classifier present) - ##marking numbers with pin ^ has undetermined meaning. Perhaps force expr matching only? - #set isgreaterthan [expr {9 in $class_key}] - #set islessthan [expr {10 in $class_key}] - - - - if {$isatom} { - #puts stdout "==>isatom $lhsspec" - set lhs [string range $lhsspec 1 end] - if {[string index $lhs end] eq "'"} { - set lhs [string range $lhs 0 end-1] - } - lset var_actions $i 1 matchatom-set - if {$lhs eq $val} { - lset match_state $i 1 - lset expected_values $i [list var $varname spec $lhsspec info match lhs $lhs rhs $val] - incr i - continue - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info strings-not-equal lhs $lhs rhs $val] - break - } - } - - - - - # - should set expected_values in each branch where match_state is not set to 1 - # - setting expected_values when match_state is set to 0 is ok except for performance - - - #todo - pinned booleans? we would need to disambiguate from a direct value match.. ie double tag as something like: ^&var or - #ispin may reclassify as isint,isdouble based on contained value (as they don't have their own classifier char and are unambiguous and require special handling) - if {$ispin} { - #puts stdout "==>ispin $lhsspec" - if {$act in [list "?set" "?matchvar-set"]} { - lset var_actions $i 1 matchvar-set - #attempt to read - upvar $lvlup $varname the_var - #if {![catch {uplevel $lvlup [list ::set $varname]} existingval]} {} - if {![catch {set the_var} existingval]} { - - if {$isbool} { - #isbool due to 2nd classifier i.e ^& - lset expected_values $i [list var $varname spec $lhsspec info test-lhs-bool lhs $existingval rhs $val] - #normalise to LHS! - lset assigned_values $i $existingval - } elseif {$isglob} { - #isglob due to 2nd classifier ^* - lset expected_values $i [list var $varname spec $lhsspec info test-lhs-glob lhs $existingval rhs $val] - } elseif {$isnumeric} { - #flagged as numeric by user using ^# classifiers - set testexistingval [join [scan $existingval %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) - if {[string is integer -strict $testexistingval]} { - set isint 1 - lset assigned_values $i $existingval - lset expected_values $i [list var $varname spec $lhsspec info test-lhs-int lhs $existingval rhs $val] - } elseif {[string is double $existingval] || [string is double -strict $testexistingval]} { - #test existingval in case something like .5 (which scan will have missed - producing empty testexistingval) - set isdouble 1 - #doubles comparisons use float_almost_equal - so lhs can differ from rhs - for pins we always want to return the normalised lhs ie exactly what is in the var - lset assigned_values $i $existingval - - lset expected_values $i [list var $varname spec $lhsspec info test-lhs-double lhs $existingval rhs $val] - } else { - #user's variable doesn't seem to have a numeric value - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info mismatch-lhs-not-numeric lhs $existingval rhs $val] - break - } - - } else { - #standard pin - single classifier ^var - lset match_state $i [expr {$existingval eq $val}] - if {![lindex $match_state $i]} { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "string-compare-not-equal" lhs $existingval rhs $val] - break - } else { - lset expected_values $i [list var $varname spec $lhsspec info "string-compare-equal" lhs $existingval rhs $val] - } - } - - } else { - #puts stdout "pinned var $varname result:$result vs val:$val" - #failure is *probably* because var is unset - but could be a read-only var due to read-trace or it could be nonexistant namespace - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info failread-$varname lhs ? rhs $val] - break - } - } - } - - - - if {$isint} { - #note - we can have classified (above) a value such as 08 on lhs as integer - even though expr and string is integer don't do so. - #expected_values $i [list var $varname spec $lhsspec info match-lhs-int lhs $existingval rhs $val] - - if {$ispin} { - set existing_expected [lindex $expected_values $i] - set lhs [dict get $existing_expected lhs] - } else { - set lhs $lhsspec ;#literal integer in the pattern - } - if {$isgreaterthan || $islessthan} { - set lhs [string range $lhsspec 0 end-1] - set testlhs $lhs - } - if {[string index $lhs 0] eq "."} { - set testlhs $lhs - } else { - set testlhs [join [scan $lhs %lld%s] ""] - } - if {[string index $val 0] eq "."} { - set testval $val - } else { - set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros) and bignums (not leading .) - } - if {[string is integer -strict $testval]} { - if {$isgreaterthan} { - #puts "lhsspec: $lhsspec testlhs: $testlhs testval: $testval" - if {$testlhs <= $testval} { - lset match_state $i 1 - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-int" lhs $lhs rhs $val] - break - } - } elseif {$islessthan} { - if {$testlhs >= $testval} { - lset match_state $i 1 - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-int" lhs $lhs rhs $val] - break - } - } else { - if {$testlhs == $testval} { - lset match_state $i 1 - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-int" lhs $lhs rhs $val] - break - } - } - } elseif {[string is double -strict $testval]} { - #dragons. (and shimmering) - if {[string first "e" $val] != -1} { - #scientific notation - let expr compare - if {$isgreaterhthan} { - if {$testlhs <= $testval} { - lset match_state $i 1 - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-sci" lhs $lhs rhs $val] - break - } - } elseif {$islessthan} { - if {$testlhs >= $testval} { - lset match_state $i 1 - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-sci" lhs $lhs rhs $val] - break - } - } else { - if {$testlhs == $testval} { - lset match_state $i 1 - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-sci" lhs $lhs rhs $val] - break - } - } - } elseif {[string is digit -strict [string trim $val -]] } { - #probably a wideint or bignum with no decimal point - #It seems odd that bignums which just look like large integers should ever compare equal if you do a +1 to one side . - #if we use float_almost_equal they may compare equal. on the other hand expr also does apparently inconsistent thins with comparing integer-like bignums vs similar sized nums with .x at the end. - #2 values further apart can compare equal while int-like ones closer together can compare different. - #The rule seems to be for bignums that if it *looks* like a whole int the comparison is exact - but otherwise the float behaviours kick in. - #This is basically what we're doing here but with an arguably better (for some purposes!) float comparison. - #string comparison can presumably always be used as an alternative. - # - #let expr compare - if {$isgreaterthan} { - if {$testlhs <= $testval} { - lset match_state $i 1 - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-puredigits" lhs $lhs rhs $val] - break - } - } elseif {$islessthan} { - if {$testlhs >= $testval} { - lset match_state $i 1 - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-puredigits" lhs $lhs rhs $val] - break - } - } else { - if {$testlhs == $testval} { - lset match_state $i 1 - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-puredigits" lhs $lhs rhs $val] - break - } - } - } else { - if {[punk::pipe::float_almost_equal $testlhs $testval]} { - lset match_state $i 1 - } else { - if {$isgreaterthan} { - if {$testlhs <= $testval} { - lset match_state $i 1 - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-float" lhs $lhs rhs $val] - break - } - } elseif {$islessthan} { - if {$testlhs >= $testval} { - lset match_state $i 1 - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-float" lhs $lhs rhs $val] - break - } - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "float_almost_equal-mismatch-int-float" lhs $lhs rhs $val] - break - } - } - } - } else { - #e.g rhs not a number.. - if {$testlhs == $testval} { - lset match_state $i 1 - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-unknown-rhstestval-$testval" lhs $lhs rhs $val] - break - } - } - } elseif {$isdouble} { - #dragons (and shimmering) - # - # - if {$ispin} { - set existing_expected [lindex $expected_values $i] - set lhs [dict get $existing_expected lhs] - } else { - set lhs $lhsspec ;#literal integer in the pattern - } - if {$isgreaterthan || $islessthan} { - error "+/- not yet supported for lhs float" - set lhs [string range $lhsspec 0 end-1] - set testlhs $lhs - } - if {[string index $val 0] eq "."} { - set testval $val ;#not something with some number of leading zeros - } else { - set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) - } - #expr handles leading 08.1 0009.1 etc without triggering octal - #so we don't need to scan lhs - if {[string first "e" $lhs] >= 0 || [string first "e" $testval] >= 0} { - if {$lhs == $testval} { - lset match_state $i 1 - lset expected_values $i [list var $varname spec $lhsspec info match-expr-sci lhs $lhs rhs $val] - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info mismatch-expr-sci lhs $lhs rhs $val] - break - } - } elseif {[string is digit -strict [string trim $lhs -]] && [string is digit -strict [string trim $val -]]} { - #both look like big whole numbers.. let expr compare using it's bignum capability - if {$lhs == $testval} { - lset match_state $i 1 - lset expected_values $i [list var $varname spec $lhsspec info match-expr-pure-digits lhs $lhs rhs $val] - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info mismatch-expr-pure-digits lhs $lhs rhs $val] - break - } - } else { - #float_almost_equal will disagree with expr based on scale.. just enough to allow for example [expr 0.2 + 0.1] to equal 0.3 - whereas expr will declare a mismatch - if {[punk::pipe::float_almost_equal $lhs $testval]} { - lset match_state $i 1 - lset expected_values $i [list var $varname spec $lhsspec info match-float-almost-equal lhs $lhs rhs $val] - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info mismatch-float-almost-equal lhs $lhs rhs $val] - break - } - } - } elseif {$isbool} { - #Note - cross binding of booleans deliberately doesn't compare actual underlying values - only that truthiness or falsiness matches. - #e.g &x/0,&x/1,&x/2= {1 2 yes} - # all resolve to true so the cross-binding is ok. - # Also - the setting of the variable x is normalized to 1 or 0 only. (true & false would perhaps be nicer - but 1 & 0 are theoretically more efficient for later comparisons as they can have a pure int rep?.) - # todo - consider the booleanString rep. Can/should we return true & false instead and maintain efficiency w.r.t shimmering? - # - #punk::pipe::boolean_equal $a $b - set extra_match_info "" ;# possible crossbind indication - set is_literal_boolean 0 - if {$ispin} { - #for a pinned boolean - the most useful return is the value in the pinned var rather than the rhs. This is not entirely consistent .. e.g pinned numbers will return rhs !review! - #As an additional pattern can always retrieve the raw value - pinned vars returning themselves (normalisation use-case ) seems the most consistent overall, and the most useful - set existing_expected [lindex $expected_values $i] - set lhs [dict get $existing_expected lhs] - } else { - set lhs [string range $lhsspec 1 end] ;# - strip off & classifier prefix - - if {![string length $lhs]} { - #empty varname - ok - if {[string is boolean -strict $val] || [string is double -strict $val]} { - lset match_state $i 1 - lset var_actions $i 1 "return-normalised-value" - lset assigned_values $i [expr {bool($val)}] - lset expected_values $i [list var $varname spec $lhsspec info "return-boolean-rhs-normalised" lhs - rhs $val] - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "mismatch-boolean-rhs" lhs - rhs $val] - break - } - } elseif {$lhs in [list 0 1]} { - #0 & 1 are the only literal numbers that satisfy Tcl's 'string is boolean' test. - set is_literal_boolean 1 - } elseif {[string index $lhs 0] eq "'" && [string index $lhs end] eq "'"} { - #literal boolean (&'yes',&'false',&'1',&'0' etc) in the pattern - #we won't waste any cycles doing an extra validity test here - it will fail in the comparison below if not a string understood by Tcl to represent a boolean. - set is_literal_boolean 1 - set lhs [string range $lhs 1 end-1] ;#strip off squotes - } else { - #todo - a standard variable name checking function for consistency.. for now we'll rule out numbers here to help avoid mistakes. - set tclvar $lhs - if {[string is double $tclvar]} { - error "pipesyntax invalid variable name '$tclvar' for boolean in pattern. (subset of legal tcl vars allowed in pattern context)" "_multi_bind_result $multivar $data $args" [list pipesyntax patternvariable invalid_boolean $tclvar] - #proc _multi_bind_result {multivar data args} - } - #treat as variable - need to check cross-binding within this pattern group - set first_bound [lsearch -index 0 $var_actions $lhsspec] - if {$first_bound == $i} { - #test only rhs (val) for boolean-ness - but boolean-ness as boolean_almost_equal understands it. (e.g floats allowed) - if {[string is boolean -strict $val] || [string is double -strict $val]} { - lset match_state $i 1 - lset var_actions $i 1 [string range $act 1 end] ;# should now be the value "set". We only need this on the first_bound - #review - consider what happens if boolean is leftmost pattern - underlying value vs normalised value to continue in pipeline - #Passing underlying value is inconsistent with what goes in the tclvar - so we need to update the returnval - #puts stderr "==========[lindex $assigned_values $i]" - lset var_actions $i 2 [expr {bool($val)}] ;#normalise to 1 or 0 - lset assigned_values $i [lindex $var_actions $i 2] - #puts stderr "==========[lindex $assigned_values $i]" - lset expected_values $i [list var $varname spec $lhsspec info "match-boolean-rhs-any-lhs" lhs - rhs $val] ;#retain underlying val in expected_values for diagnostics. - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "mismatch-boolean-rhs-any-lhs" lhs - rhs $val] - break - } - } else { - set expectedinfo [lindex $expected_values $first_bound] - set expected_earlier [dict get $expectedinfo rhs] - set extra_match_info "-crossbind-first" - set lhs $expected_earlier - } - } - } - - - #may have already matched above..(for variable) - if {[lindex $match_state $i] != 1} { - if {![catch {punk::pipe::boolean_almost_equal $lhs $val} ismatch]} { - if {$ismatch} { - lset match_state $i 1 - lset expected_values $i [list var $varname spec $lhsspec info match-boolean-almost-equal$extra_match_info lhs $lhs rhs $val] - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info mismatch-boolean-almost-equal$extra_match_info lhs $lhs rhs $val] - break - } - } else { - #we should only error from boolean_equal if passed something Tcl doesn't recognise as a boolean - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info badvalue-boolean$extra_match_info lhs $lhs rhs $val] - break - } - } - - } elseif {$isglob} { - if {$ispin} { - set existing_expected [lindex $expected_values $i] - set lhs [dict get $existing_expected lhs] - } else { - set lhs $lhsspec ;#literal glob in the pattern - no classifier prefix - } - if {[string match $lhs $val]} { - lset match_state $i 1 - lset expected_values $i [list var $varname spec $lhsspec info "match-glob" lhs $lhs rhs $val] - } else { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "mismatch-glob" lhs $lhs rhs $val] - break - } - - } elseif {$ispin} { - #handled above.. leave case in place so we don't run else for pins - - } else { - #puts stdout "==> $lhsspec" - #NOTE - pinned var of same name is independent! - #ie ^x shouldn't look at earlier x bindings in same pattern - #unpinned non-atoms - #cross-binding. Within this multivar pattern group only (use pin ^ for binding to result from a previous pattern) - # - switch -- $varname { - "" { - #don't attempt cross-bind on empty-varname - lset match_state $i 1 - #don't change var_action $i 1 to set - lset expected_values $i [list var $varname spec $lhsspec info "match-no-lhs-var" lhs - rhs $val] - } - "_" { - #don't cross-bind on the special 'don't-care' varname - lset match_state $i 1 - lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set - lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs-dontcare-var" lhs - rhs $val] - } - default { - set first_bound [lsearch -index 0 $var_actions $varname] - #assertion first_bound >=0, we will always find something - usually self - if {$first_bound == $i} { - lset match_state $i 1 - lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set - lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs" lhs - rhs $val] - } else { - assert {$first_bound < $i} assertion_fail: _multi_bind_result condition: [list $first_bound < $i] - set expectedinfo [lindex $expected_values $first_bound] - set expected_earlier [dict get $expectedinfo rhs] - if {$expected_earlier ne $val} { - lset match_state $i 0 - lset expected_values $i [list var $varname spec $lhsspec info "mismatch-crossbind-first" lhs $expected_earlier rhs $val] - break - } else { - lset match_state $i 1 - #don't convert ?set to set - or var setter will write for each crossbound instance. Possibly no big deal for performance - but could trigger unnecessary write traces for example - #lset var_actions $i 1 [string range $act 1 end] - lset expected_values $i [list var $varname spec $lhsspec info "match-crossbind-first" lhs $expected_earlier rhs $val] - } - } - } - } - } - - incr i - } - - #JMN2 - review - #set returnval [lindex $assigned_values 0] - if {[llength $assigned_values] == 1} { - set returnval [join $assigned_values] - } else { - set returnval $assigned_values - } - #puts stdout "----> > rep returnval: [rep $returnval]" - - - - - - #-------------------------------------------------------------------------- - #Variable assignments (set) should only occur down here, and only if we have a match - #-------------------------------------------------------------------------- - set match_count_needed [llength $var_actions] - #set match_count [expr [join $match_state +]] ;#expr must be unbraced here - set matches [lsearch -all -inline $match_state 1] ;#default value for each match_state entry is "?" - set match_count [llength $matches] - - - debug.punk.pipe.var {MATCH_STATE: $match_state count_needed: $match_count_needed vs match_count: $match_count} 4 - debug.punk.pipe.var {VARACTIONS2: $var_actions} 5 - debug.punk.pipe.var {EXPECTED : $expected_values} 4 - - #set match_count [>f . foldl 0 [>f . sum .] $match_state] ;#ok method.. but slow compared to expr with join - if {$match_count == $match_count_needed} { - #do assignments - for {set i 0} {$i < [llength $var_actions]} {incr i} { - if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} { - #isvar - if {[lindex $var_actions $i 1] eq "set"} { - upvar $lvlup $varname the_var - set the_var [lindex $var_actions $i 2] - } - } - } - dict set returndict ismatch 1 - #set i 0 - #foreach va $var_actions { - # #set isvar [expr {[lindex $var_class $i 1] == 6}] - # if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} { - # #isvar - # lassign $va lhsspec act val - # upvar $lvlup $varname the_var - # if {$act eq "set"} { - # set the_var $val - # } - # #if {[lindex $var_actions $i 1] eq "set"} { - # # set the_var $val - # #} - # } - # incr i - #} - } else { - #todo - some way to restrict mismatch info to simple "mismatch" and avoid overhead of verbose message - #e.g for within pipeswitch block where mismatches are expected and the reasons are less important than moving on quickly - set vidx 0 - #set mismatches [lmap m $match_state v $var_names {expr {$m == 0} ? {[list mismatch $v]} : {[list match $v]}}] - set mismatches [lmap m $match_state v $var_names {expr {$m == 0 ? [list mismatch $v] : [list match $v]}}] - set var_display_names [list] - foreach v $var_names { - if {$v eq ""} { - lappend var_display_names {{}} - } else { - lappend var_display_names $v - } - } - #REVIEW 2025 - #set mismatches_display [lmap m $match_state v $var_display_names {expr {$m == 0} ? {$v} : {[expr {$m eq "?"} ? {"?[string repeat { } [expr [string length $v] -1]]"} : {[string repeat " " [string length $v]]} ]}}] - set mismatches_display [lmap m $match_state v $var_display_names {expr {$m == 0 ? $v : [expr {$m eq "?" ? "?[string repeat { } [expr {[string length $v] -1}]]" : [string repeat " " [string length $v]] }]}}] - set msg "\n" - append msg "Unmatched\n" - append msg "Cannot match right hand side to pattern $multivar\n" - append msg "vars/atoms/etc: $var_names\n" - append msg "mismatches: [join $mismatches_display { } ]\n" - set i 0 - #0 - novar - #1 - atom ' - #2 - pin ^ - #3 - boolean & - #4 - integer - #5 - double - #6 - var - #7 - glob (no classifier and contains * or ?) - foreach mismatchinfo $mismatches { - lassign $mismatchinfo status varname - if {$status eq "mismatch"} { - # varname can be empty string - set varclass [lindex $var_class $i 1] - set val [lindex $var_actions $i 2] - set e [dict get [lindex $expected_values $i] lhs] - set type "" - if {2 in $varclass} { - append type "pinned " - } - - if {$varclass == 1} { - set type "atom" - } elseif {$varclass == 2} { - set type "pinned var" - } elseif {3 in $varclass} { - append type "boolean" - } elseif {4 in $varclass} { - append type "int" - } elseif {5 in $varclass} { - append type "double" - } elseif {$varclass == 6} { - set type "var" - } elseif {7 in $varclass} { - append type "glob" - } elseif {8 in $varclass} { - append type "numeric" - } - if {$type eq ""} { - set type "" - } - - set lhs_tag "- [dict get [lindex $expected_values $i] info]" - set mmaction [lindex $var_actions $i 1] ;#e.g ?mismatch-dict-index-out-of-range - set tag "?mismatch-" - if {[string match $tag* $mmaction]} { - set mismatch_reason [string range $mmaction [string length $tag] end] - } else { - set mismatch_reason $mmaction - } - append msg " $type: '$varname' $mismatch_reason $lhs_tag LHS: '$e' vs RHS: '$val'\n" - } - incr i - } - #error $msg - dict unset returndict result - #structured error return - used by pipeswitch/pipecase - matching on "binding mismatch*" - dict set returndict mismatch [dict create binding mismatch varnames $var_names matchinfo $mismatches display $msg data $data] - return $returndict - } - - if {![llength $var_names]} { - #var_name entries can be blank - but it will still be a list - #JMN2 - #dict set returndict result [list $data] - dict set returndict result $data - } else { - assert {$i == [llength $var_names]} assertion_fail _multi_bind_result condition {$i == [llength $var_names]} - dict set returndict result $returnval - } - return $returndict - } - - ######################################################## - # dragons. - # using an error as out-of-band way to signal mismatch is the easiest. - # It comes at some cost (2us 2023?) to trigger catches. (which is small relative to uncompiled pipeline costs in initial version - but per pattern mismatch will add up) - # The alternative of attempting to tailcall return the mismatch as data - is *hard* if not impossible to get right. - # We need to be able to match on things like {error {mismatch etc}} - without it then itself being interpreted as a mismatch! - # A proper solution may involve a callback? tailcall some_mismatch_func? - # There may be a monad-like boxing we could do.. to keep it in data e.g {internalresult match } {internalresult mismatch } and be careful to not let boxed data escape ?? - # make sure there is good test coverage before experimenting with this - proc _handle_bind_result {d} { - #set match_caller [info level 2] - #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 - if {![dict exists $d result]} { - #uplevel 1 [list error [dict get $d mismatch]] - #error [dict get $d mismatch] - return -code error -errorcode [list binding mismatch varnames [dict get $d mismatch varnames]] [dict get $d mismatch] - } else { - return [dict get $d result] - } - } - # initially promising - but the approach runs into impossible disambiguation of mismatch as data vs an actual mismatch - proc _handle_bind_result_experimental1 {d} { - #set match_caller [info level 2] - #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 - if {![dict exists $d result]} { - tailcall return [dict get $d mismatch] - } else { - return [dict get $d result] - } - } - ######################################################## - - #timings very similar. listset3 closest in performance to pipeset. review - test on different tcl versions. - #Unfortunately all these variations seem around 10x slower than 'set list {a b c}' or 'set list [list a b c]' - #there seems to be no builtin for list setting with args syntax. lappend is close but we would need to catch unset the var first. - #proc listset1 {listvarname args} { - # tailcall set $listvarname $args - #} - #interp alias {} listset2 {} apply {{vname args} {tailcall set $vname $args}} - #interp alias {} listset3 {} apply {{vname args} {upvar $vname v; set v $args}} - proc pipeset {pipevarname args} { - upvar $pipevarname the_pipe - set the_pipe $args - } - - #pipealias should capture the namespace context of the pipeline so that commands are resolved in the namespace in which the pipealias is created - proc pipealias {targetcmd args} { - set cmdcopy [punk::objclone $args] - set nscaller [uplevel 1 [list namespace current]] - tailcall interp alias {} $targetcmd {} apply [list args [append cmdcopy " {*}\$args"] $nscaller] - } - proc pipealias_extract {targetcmd} { - set applybody [lindex [interp alias "" $targetcmd] 1 1] - #strip off trailing " {*}$args" - return [lrange [string range $applybody 0 end-9] 0 end] - } - #although the pipealias2 'concat' alias is cleaner in that the original pipeline can be extracted using list commands - it runs much slower - proc pipealias2 {targetcmd args} { - set cmdcopy [punk::objclone $args] - set nscaller [uplevel 1 [list namespace current]] - tailcall interp alias {} $targetcmd {} apply [list args [concat "\[concat" [list $cmdcopy] "\$args]"] $nscaller] - } - - - #same as used in unknown func for initial launch - #variable re_assign {^([^\r\n=\{]*)=(.*)} - #variable re_assign {^[\{]{0,1}([^ \t\r\n=]*)=(.*)} - variable re_assign {^([^ \t\r\n=\{]*)=(.*)} - variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} - #match_assign is tailcalled from unknown - uplevel 1 gets to caller level - proc match_assign {scopepattern equalsrhs args} { - #review - :: is legal in atoms! - if {[string match "*::*" $scopepattern]} { - error "match_assign scopepattern '$scopepattern' contains namespace separator '::' - invalid." - } - #puts stderr ">> match_assign '$scopepattern=$equalsrhs' $args" - set fulltail $args - set cmdns ::punk::pipecmds - set namemapping [punk::pipe::lib::pipecmd_namemapping $equalsrhs] - - #we deliberately don't call pipecmd_namemapping on the scopepattern even though it may contain globs. REVIEW - #(we need for example x*= to be available as is via namespace path mechanism (from punk::pipecmds namespace)) - - set pipecmd ${cmdns}::$scopepattern=$namemapping - - #pipecmd could have glob chars - test $pipecmd in the list - not just that info commands returns results. - if {$pipecmd in [info commands $pipecmd]} { - #puts "==nscaller: '[uplevel 1 [list namespace current]]'" - #uplevel 1 [list ::namespace import $pipecmd] - set existing_path [uplevel 1 [list ::namespace path]] - if {$cmdns ni $existing_path} { - uplevel 1 [list ::namespace path [concat $existing_path $cmdns]] - } - tailcall $pipecmd {*}$args - } - - - #NOTE: - #we need to ensure for case: - #= x=y - #that the second arg is treated as a raw value - never a pipeline command - - #equalsrhs is set if there is a segment-insertion-pattern *directly* after the = - #debug.punk.pipe {match_assign '$multivar' '$equalsrhs' '$fulltail'} 4 - #can match pattern on lhs with a value where pattern is a minilang that can refer to atoms (simple non-whitespace strings), numbers, or varnames (possibly pinned) as well as a trailing spec for position within the data. - - # allow x=insertionpattern to begin a pipeline e.g x= |> string tolower ? or x=1 a b c <| X to produce a X b c - # - #to assign an entire pipeline to a var - use pipeset varname instead. - - # in our script's handling of args: - #avoid use of regexp match on each element - or we will unnecessarily force string reps on lists - #same with lsearch with a string pattern - - #wouldn't matter for small lists - but we need to be able to handle large ones efficiently without unneccessary string reps - set script [string map [list $scopepattern $equalsrhs] { - #script built by punk::match_assign - if {[llength $args]} { - #scan for existence of any pipe operator (|*> or <*|) only - we don't need position - #all pipe operators must be a single element - #we don't first check llength args == 1 because for example: - # x= <| - # x= |> - #both leave x empty. To assign a pipelike value to x we would have to do: x= <| |> (equiv: set x |>) - foreach a $args { - if {![catch {llength $a} sublen]} { - #don't enforce sublen == 1. Legal to have whitespace including newlines {| x >} - if {[string match |*> $a] || [string match <*| $a]} { - tailcall punk::pipeline = "" "" {*}$args - } - } - } - if {[llength $args] == 1} { - set segmenttail [lindex $args 0] - } else { - error "pipedata = must take a single argument. Got [llength $args] args: '$args'" "match_assign $args" [list pipedata segment too_many_elements segment_type =] - } - } else { - #set segmenttail [purelist] - set segmenttail [lreplace x 0 0] - } - }] - - - - - if {[string length $equalsrhs]} { - # as we aren't in a pipleine - there is no data to insert - we proably still need to run _split_equalsrhs to verify the syntax. - # review - consider way to turn it off as optimisation for non-pipelined assignment - but generally standard Tcl set could be used for that purpose. - # We are probably only here if testing in the repl - in which case the error messages are important. - set var_index_position_list [punk::pipe::lib::_split_equalsrhs $equalsrhs] - #we may have an insertion-spec that inserts a literal atom e.g to wrap in "ok" - # x='ok'>0/0 data - # => {ok data} - # we won't examine for vars as there is no pipeline - ignore - # also ignore trailing * (indicator for variable data to be expanded or not - ie {*}) - # we will differentiate between / and @ in the same way that general pattern matching works. - # /x will simply call linsert without reference to length of list - # @x will check for out of bounds - # - # !TODO - sort by position lowest to highest? or just require user to order the pattern correctly? - - - - foreach v_pos $var_index_position_list { - lassign $v_pos v indexspec positionspec - #e.g =v1/1>0 A pattern predator system) - # - #todo - review - # - # - #for now - the script only needs to handle the case of a single segment pipeline (no |> <|) - - - #temp - needs_insertion - #we can safely output no script for variable insertions for now - because if there was data available, - #we would have to be in a pipeline - in which case the script above would have delegated all our operations anyway. - #tag: positionspechandler - if {([string index $v 0] eq "'" && [string index $v end] eq "'") || [string is integer -strict $v]} { - #(for now)don't allow indexspec on a literal value baked into the pipeline - it doesn't really make sense - #- unless the pipeline construction has been parameterised somehow e.g "=${something}/0" - #review - if {[string length $indexspec]} { - error "pipesyntax literal value $v - index specification not allowed (match_assign)1" "match_assign $scopepattern $equalsrhs $args" [list pipesyntax index_on_literal] - } - if {[string index $v 0] eq "'" && [string index $v end] eq "'"} { - set datasource [string range $v 1 end-1] - } elseif {[string is integer -strict $v]} { - set datasource $v - } - append script [string map [list $datasource] { - set insertion_data "" ;#atom could have whitespace - }] - - set needs_insertion 1 - } elseif {$v eq ""} { - #default variable is 'data' - set needs_insertion 0 - } else { - append script [string map [list $v] { - #uplevel? - #set insertion_data [set ] - }] - set needs_insertion 0 - } - if {$needs_insertion} { - set script2 [punk::list_insertion_script $positionspec segmenttail ] - set script2 [string map [list "\$insertion_data" ] $script2] - append script $script2 - } - - - } - - - } - - if {![string length $scopepattern]} { - append script { - return $segmenttail - } - } else { - append script [string map [list $scopepattern] { - #we still need to bind whether list is empty or not to allow any patternmatch to succeed/fail - set d [punk::_multi_bind_result {} $segmenttail] - #return [punk::_handle_bind_result $d] - #maintenance: inlined - if {![dict exists $d result]} { - #uplevel 1 [list error [dict get $d mismatch]] - #error [dict get $d mismatch] - return -code error -level 1 -errorcode [list binding mismatch] [dict get $d mismatch] - } else { - return [dict get $d result] - } - }] - } - - debug.punk.pipe.compile {match_assign creating proc $pipecmd} 2 - uplevel 1 [list ::proc $pipecmd args $script] - set existing_path [uplevel 1 [list ::namespace path]] - if {$cmdns ni $existing_path} { - uplevel 1 [list ::namespace path [concat $existing_path $cmdns]] - } - tailcall $pipecmd {*}$args - } - - #return a script for inserting data into listvar - #review - needs updating for list-return semantics of patterns? - proc list_insertion_script {keyspec listvar {data }} { - set positionspec [string trimright $keyspec "*"] - set do_expand [expr {[string index $keyspec end] eq "*"}] - if {$do_expand} { - set exp {{*}} - } else { - set exp "" - } - #NOTE: linsert and lreplace can take multiple values at tail ie expanded data - - set ptype [string index $positionspec 0] - if {$ptype in [list @ /]} { - set index [string range $positionspec 1 end] - } else { - #the / is optional (default) at first position - and we have already discarded the ">" - set ptype "/" - set index $positionspec - } - #puts stderr ">> >> $index" - set script "" - set isint [string is integer -strict $index] - if {$index eq "."} { - #do nothing - this char signifies no insertion - } elseif {$isint || [regexp {^(end|end[-+]{1,2}[0-9]+)$} $index]} { - if {$ptype eq "@"} { - #compare position to *possibly updated* list - note use of $index > $datalen rather than $index+1 > $datalen - (we allow 'insertion' at end of list by numeric index) - if {$isint} { - append script [string map [list $listvar $index] { - if {( > [llength $])} { - #not a pipesyntax error - error "pipedata insertionpattern index out of bounds. index: vs len: [llength $] use /x instead of @x to avoid check (list_insertion_script)" "list_insertion_script $keyspec" [list pipedata insertionpattern index_out_f_bounds] - } - }] - } - #todo check end-x bounds? - } - if {$isint} { - append script [string map [list $listvar $index $exp $data] { - set [linsert [lindex [list $ [unset ]] 0] ] - }] - } else { - append script [string map [list $listvar $index $exp $data] { - #use inline K to make sure the list is unshared (optimize for larger lists) - set [linsert [lindex [list $ [unset ]] 0] ] - }] - - } - } elseif {[string first / $index] < 0 && [string first - $index] > 0} { - if {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { - #also - range checks for @ which must go into script !!! - append script [string map [list $listvar $start $end $exp $data] { - set [lreplace [lindex [list $ [unset ]] 0] ] - }] - } else { - error "pipesyntax error in segment insertionpattern - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)2" "list_insertion_script $keyspec" [list pipedata insertionpattern_invalid] - } - } elseif {[string first / $index] >= 0} { - #nested insertion e.g /0/1/2 /0/1-1 - set parts [split $index /] - set last [lindex $parts end] - if {[string first - $last] >=0} { - lassign [split $last -] a b - if {![regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $last _ a b]} { - error "pipesyntax error in segment insertionpattern - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)3" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] - } - if {$a eq $b} { - if {!$do_expand} { - #we can do an lset - set lsetkeys [list {*}[lrange $parts 0 end-1] $a] - append script [string map [list $listvar $lsetkeys $data] { - lset - }] - } else { - #we need to lreplace the containing item - append script [string map [list $listvar [lrange $parts 0 end-1] $a $data] { - set target [lindex $ ] - lset target {*} - lset $target - }] - } - } else { - #we need to lreplace a range at the target level - append script [string map [list $listvar [lrange $parts 0 end-1] $a $b $exp $data] { - set target [lindex $ ] - set target [lreplace $target ] - lset $target - }] - } - } else { - #last element has no -, so we are inserting at the final position - not replacing - append script [string map [list $listvar [lrange $parts 0 end-1] $last $exp $data] { - set target [lindex $ ] - set target [linsert $target ] - lset $target - }] - } - - - } else { - error "pipesyntax error in segment - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)4" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] - } - return $script - } - - - - - proc _is_math_func_prefix {e1} { - #also catch starting brackets.. e.g "(min(4,$x) " - if {[regexp {^[^[:alnum:]]*([[:alnum:]]*).*} $e1 _ word]} { - #possible math func - if {$word in [info functions]} { - return true - } - } - return false - } - - #todo - option to disable these traces which provide clarifying errors (performance hit?) - proc pipeline_args_read_trace_error {args} { - error "The pipelined data doesn't appear to be a valid Tcl list\nModify input, or use \$data or another variable name instead of \$args." "pipeline_args_read_trace_error $args" [list pipedata args_unavailable_data_not_a_list] - } - - - #NOTE: the whole idea of scanning for %x% is a lot of work(performance penalty) - #consider single placeholder e.g "_" as only positional indicator - for $data only - and require braced script with $var for more complex requirements - #possibly also *_ for expanded _ ? - #This would simplify code a lot - but also quite possible to collide with user data. - #Perhaps not a big deal as unbraced segments between |> are mainly(?) a convenience for readability/repl etc. - # (but importantly (at pipeline start anyway) unbraced segments are a mechanism to inject data from calling scope or from pipeline args <|) - # - #detect and retrieve %xxx% elements from item without affecting list/string rep - #commas, @, ', ^ and whitespace not part of a valid tag (allows some substitution within varspecs) - #%% is not a valid tag - #(as opposed to using regexp matching which causes string reps) - proc get_tags {item} { - set chars [split $item {}] - set terminal_chars [list , @ ' ^ " " \t \n \r] - #note % is both terminal and initiating - so for the algorithm we don't include it in the list of terminal_chars - set nonterminal [lmap v $chars {expr {$v ni $terminal_chars}}] - set percents [lmap v $chars {expr {$v eq "%"}}] - #useful for test/debug - #puts "CHARS : $chars" - #puts "NONTERMINAL: $nonterminal" - #puts "PERCENTS : $percents" - set sequences [list] - set in_sequence 0 - set start -1 - set end -1 - set i 0 - #todo - some more functional way of zipping/comparing these lists? - set s_length 0 ;#sequence length including % symbols - minimum for tag therefore 2 - foreach n $nonterminal p $percents { - if {!$in_sequence} { - if {$n & $p} { - set s_length 1 - set in_sequence 1 - set start $i - set end $i - } else { - set s_length 0 - } - } else { - if {$n ^ $p} { - incr s_length - incr end - } else { - if {$n & $p} { - if {$s_length == 1} { - # % followed dirctly by % - false start - #start again from second % - set s_length 1 - set in_sequence 1 - set start $i - set end $i - } else { - incr end - lappend sequences [list $start $end] - set in_sequence 0 - set s_length 0 - set start -1; set end -1 - } - } else { - #terminated - not a tag - set in_sequence 0 - set s_length 0 - set start -1; set end -1 - } - } - } - incr i - } - - set tags [list] - foreach s $sequences { - lassign $s start end - set parts [lrange $chars $start $end] - lappend tags [join $parts ""] - } - return $tags - } - - #show underlying rep of list and first level - proc rep_listname {lname} { - upvar $lname l - set output "$lname list rep: [rep $l]\n" - foreach item $l { - append output "-rep $item\n" - append output " [rep $item]\n" - } - return $output - } - - - # -- - #consider possible tilde templating version ~= vs .= - #support ~ and ~* placeholders only. - #e.g x~= list aa b c |> lmap v ~ {string length $v} |> tcl::mathfunc::max ~* - #The ~ being mapped to $data in the pipeline. - #This is more readable and simpler for beginners - although it doesn't handle more advanced insertion requirements. - #possibility to mix as we can already with .= and = - #e.g - #x.= list aa b c |> ~= lmap v ~ {string length $v} |> .=>* tcl::mathfunc::max - # -- - proc pipeline {segment_op initial_returnvarspec equalsrhs args} { - set fulltail $args - #unset args ;#leave args in place for error diagnostics - debug.punk.pipe {call pipeline: op:'$segment_op' '$initial_returnvarspec' '$equalsrhs' '$fulltail'} 4 - #debug.punk.pipe.rep {[rep_listname fulltail]} 6 - - - #--------------------------------------------------------------------- - # test if we have an initial x.=y.= or x.= y.= - - #nextail is tail for possible recursion based on first argument in the segment - #set nexttail [lassign $fulltail next1] ;#tail head - - set next1 [lindex $args 0] - switch -- $next1 { - pipematch { - set nexttail [lrange $args 1 end] - set results [uplevel 1 [list pipematch {*}$nexttail]] - debug.punk.pipe {>>> pipematch results: $results} 1 - - set d [_multi_bind_result $initial_returnvarspec $results] - return [_handle_bind_result $d] - } - pipecase { - set msg "pipesyntax\n" - append msg "pipecase does not return a value directly in the normal way\n" - append msg "It will return a casemismatch dict on mismatch\n" - append msg "But on a successful match - it will use an 'error' mechanism to return {ok result {something}} in the caller's scope -\n" - append msg "This will appear as an error in the repl, or disrupt pipeline result propagation if not in an appropriate wrapper\n" - append msg "Call pipecase from within a pipeline script block or wrapper such as pipeswitch or apply." - error $msg - } - } - - #temp - this is related to a script for the entire pipeline (functional composition) - not the script for the segment-based x=y or x.=y proc. - set ::_pipescript "" - - - - #NOTE: - #important that for assignment: - #= x=y .. - #The second element is always treated as a raw value - not a pipeline instruction. - #whereas... for execution: - #.= x=y the second element is a pipeline-significant symbol based on the '=' even if it was passed in as an argument. - #Usually an execution segment (.= cmd etc..) will have args inserted at the tail anyway - - #- but if the pipeline is designed to put an argument in the zero position - then presumably it is intended as a pipeline-significant element anyway - #This gives a *slight* incompatibility with external commands containing '=' - in that they may not work properly in pipelines - # - if {$segment_op ne "="} { - #handle for example: - #var1.= var2= "etc" |> string toupper - # - #var1 will contain ETC (from entire pipeline), var2 will contain etc (from associated segment) - # - - if {([set nexteposn [string last = $next1]] >= 0) && (![punk::pipe::lib::arg_is_script_shaped $next1]) } { - set nexttail [lrange $args 1 end] - #*SUB* pipeline recursion. - #puts "======> recurse based on next1:$next1 " - if {[string index $next1 $nexteposn-1] eq {.}} { - #var1.= var2.= ... - #non pipelined call to self - return result - set results [uplevel 1 [list $next1 {*}$nexttail]] - #debug.punk.pipe.rep {==> rep recursive results: [rep $results]} 5 - #debug.punk.pipe {>>> results: $results} 1 - return [_handle_bind_result [_multi_bind_result $initial_returnvarspec $results]] - } - #puts "======> recurse assign based on next1:$next1 " - #if {[regexp {^([^ \t\r\n=\{]*)=(.*)} $next1 _ nextreturnvarspec nextrhs]} { - #} - #non pipelined call to plain = assignment - return result - set results [uplevel 1 [list $next1 {*}$nexttail]] - #debug.punk.pipe {>>> results: $results} 1 - set d [_multi_bind_result $initial_returnvarspec $results] - return [_handle_bind_result $d] - } - } - - set procname $initial_returnvarspec.=$equalsrhs - - #--------------------------------------------------------------------- - - #todo add 'op' argument and handle both .= and = - # - #|> data piper symbol - #<| args piper symbol (arguments supplied at end of pipeline e.g from commandline or from calling and/or currying the command) - # - - set more_pipe_segments 1 ;#first loop - - #this contains the main %data% and %datalist% values going forward in the pipeline - #as well as any extra pipeline vars defined in each |> - #It also contains any 'args' with names supplied in <| - set dict_tagval [dict create] ;#cumulative %x% tag dict which operates on the whole length of the pipeline - - #determine if there are input args at the end of the pipeline indicated by reverse <| symbol possibly with argspecs e.g transform x y z =0} { - set tailremaining [lrange $fulltail 0 $firstargpipe_posn-1] - set argslist [lrange $fulltail $firstargpipe_posn+1 end] ;#Note that this could be a whole other pipeline with |> and/or <| elements. - set argpipe [lindex $fulltail $firstargpipe_posn] - set argpipespec [string range $argpipe 1 end-1] ;# strip off < & | from " b1 b2 b3 |outpipespec> c1 c2 c3 - # for a1 a2 a3 - the pipe to the right is actually an outpipespec and for c1 c2 c3 the pipe to the left is an inpipespec - - - #our initial command list always has *something* before we see any pipespec |> - #Therefore we initially have a blank inpipespec (although in effect, it comes from the argpipespec <|) - set inpipespec $argpipespec - set outpipespec "" - - #avoiding regexp on each arg to maintain list reps - #set tailmap [lmap v $tailremaining {lreplace [split $v {}] 1 end-1}] - ## set tailmap [lmap v $tailremaining {if {[regexp {^\|(.*)>$} $v _ outpipespec] && !$pipeseen} {set pipeseen 1;set outpipespec} {if {$pipeseen} {set v} 0}}] - #e.g for: a b c |> e f g |> h - #set firstpipe_posn [lsearch $tailmap {| >}] - - set firstpipe_posn [lsearch $tailremaining "|*>"] - - if {$firstpipe_posn >=0} { - set outpipespec [string range [lindex $tailremaining $firstpipe_posn] 1 end-1] - set segment_members [lrange $tailremaining 0 $firstpipe_posn-1] - #set tailremaining [lrange $tailremaining $firstpipe_posn+1 end] - set tailremaining [lreplace $tailremaining 0 $firstpipe_posn] ;#generally too short for any K combinator benefit? what about lists with scripts? is it dependent on list length or also element content size? - } else { - set segment_members $tailremaining - set tailremaining [list] - } - - - - set script_like_first_word 0 - set rhs $equalsrhs - - set segment_first_is_script 0 ;#default assumption until tested - - set segment_first_word [lindex $segment_members 0] - if {$segment_op ne "="} { - if {[punk::pipe::lib::arg_is_script_shaped $segment_first_word]} { - set segment_first_is_script 1 - } - } else { - if {[llength $segment_members] > 1} { - error "pipedata = can only accept a single argument (got: '$segment_members')" "pipeline $segment_op $initial_returnvarspec $equalsrhs $fulltail" [list pipedata too_many_elements] - #proc pipeline {segment_op initial_returnvarspec equalsrhs args} - } - set segment_members $segment_first_word - } - - - - #tailremaining includes x=y during the loop. - set returnvarspec $initial_returnvarspec - if {![llength $argslist]} { - unset -nocomplain previous_result ;# we want it unset for first iteration - differentiate from empty string - } else { - set previous_result $argslist - } - - set segment_result_list [list] - set i 0 ;#segment id - set j 1 ;#next segment id - set pipespec(args) $argpipespec ;# from trailing <| - set pipespec(0,in) $inpipespec - set pipespec(0,out) $outpipespec - - set max_iterations 100 ;# configurable? -1 for no limit ? This is primarily here to aid debugging of runaway loops in initial development .. should probably set to no-limit in final version. - while {$more_pipe_segments == 1} { - #--------------------------------- - debug.punk.pipe {[a yellow bold]i$i SEGMENT MEMBERS([llength $segment_members]): $segment_members[a]} 4 - debug.punk.pipe {[a yellow bold]i$i TAIL REMAINING([llength $tailremaining]): $tailremaining[a]} 4 - debug.punk.pipe {[a] inpipespec(prev [a yellow bold]|$pipespec($i,in)[a]>) outpipespec(next [a+ yellow bold]|$pipespec($i,out)>[a])} 4 - debug.punk.pipe {[a cyan bold] segment_first_is_script:$segment_first_is_script} 4 - if {$segment_first_is_script} { - debug.punk.pipe {[a cyan bold] script segment: [lindex $segment_members 0][a]} 4 - } - - - - #examine inpipespec early to give faster chance for mismatch. ie before scanning segment for argument position - set segment_result "" - if {[info exists previous_result]} { - set prevr $previous_result - } else { - set prevr "" - } - set pipedvars [dict create] - if {[string length $pipespec($i,in)]} { - #check the varspecs within the input piper - # - data and/or args may have been manipulated - set d [apply {{mv res} { - punk::_multi_bind_result $mv $res -levelup 1 - }} $pipespec($i,in) $prevr] - #temp debug - #if {[dict exists $d result]} { - #set jjj [dict get $d result] - #puts "!!!!! [rep $jjj]" - #} - set inpipespec_result [_handle_bind_result $d] - set pipedvars [dict get $d setvars] - set prevr $inpipespec_result ;# leftmost spec in |> needs to affect pipeline flow of 'data' - #puts stdout "inpipespec:|$pipespec($i,in)> prevr:$prevr setvars: $pipedvars" - } - debug.punk.pipe {[a] previous_iteration_result: $prevr[a]} 6 - debug.punk.pipe.rep {rep previous_iteration_result [rep $prevr]} - - - if {$i == $max_iterations} { - puts stderr "ABORTING. Reached max_iterations $max_iterations (todo: make configurable)" - set more_pipe_segments 0 - } - - set insertion_patterns [punk::pipe::lib::_split_equalsrhs $rhs] ;#raises error if rhs of positionspec not like /* or @* - set segment_has_insertions [expr {[llength $insertion_patterns] > 0}] - #if {$segment_has_insertions} { - # puts stdout ">>> $segment_members insertion_patterns $insertion_patterns" - #} - - debug.punk.pipe.var {segment_has_insertions: $insertion_patterns} 5 - debug.punk.pipe.rep {[rep_listname segment_members]} 4 - - - - - #whether the segment has insertion_patterns or not - apply any modification from the piper argspecs (script will use modified args/data) - #pipedvars comes from either previous segment |>, or <| args - if {[dict exists $pipedvars "data"]} { - #dict set dict_tagval %data% [list [dict get $pipedvars "data"]] - dict set dict_tagval data [dict get $pipedvars "data"] - } else { - if {[info exists previous_result]} { - dict set dict_tagval data $prevr - } - } - foreach {vname val} $pipedvars { - #add additionally specified vars and allow overriding of %args% and %data% by not setting them here - if {$vname eq "data"} { - #already potentially overridden - continue - } - dict set dict_tagval $vname $val - } - - #todo! - #segment_script - not in use yet. - #will require non-iterative pipeline processor to use ... recursive.. or coroutine based - set script "" - - if {!$segment_has_insertions} { - #debug.punk.pipe.var {[a cyan]SEGMENT has no tags[a]} 7 - #add previous_result as data in end position by default, only if *no* insertions specified (data is just list-wrapped previous_result) - #set segment_members_filled [concat $segment_members [dict get $dict_tagval %data%]] ;# data flows through by default as single element - not args - because some strings are not valid lists - #insertion-specs with a trailing * can be used to insert data in args format - set segment_members_filled $segment_members - if {[dict exists $dict_tagval data]} { - lappend segment_members_filled [dict get $dict_tagval data] - } - - } else { - debug.punk.pipe.var {processing insertion_pattern dict_tagval: $dict_tagval} 4 - set segment_members_filled [list] - set segmenttail $segment_members ;# todo - change to segment_members here to match punk::match_assign - - set rhsmapped [punk::pipe::lib::pipecmd_namemapping $rhs] - set cmdname "::punk::pipecmds::insertion::_$rhsmapped" - #glob chars have been mapped - so we can test by comparing info commands result to empty string - if {[info commands $cmdname] eq ""} { - - set insertion_script "proc $cmdname {dict_tagval segmenttail} {\n" - foreach v_pos $insertion_patterns { - #puts stdout "v_pos '$v_pos'" - lassign $v_pos v indexspec positionspec ;#v may be atom, or varname (in pipeline scope) - #puts stdout "v:'$v' indexspec:'$indexspec' positionspec:'$positionspec'" - #julz - - append insertion_script \n [string map [list $v_pos] { - lassign [list ] v indexspec positionspec - }] - - if {([string index $v 0] eq "'") && ([string index $v end] eq "'")} { - set v [string range $v 1 end-1] ;#assume trailing ' is present! - if {[string length $indexspec]} { - error "pipesyntax - index not supported on atom" "pipeline $segment_op $initial_returnvarspec $equalsrhs $args" [list pipesyntax index_on_literal] - } - append insertion_script \n "set insertion_data [list $v]" ;#sub in shortened $v now -i.e use atom value itself (string within single quotes) - } elseif {[string is double -strict $v]} { - #don't treat numbers as variables - if {[string length $indexspec]} { - error "pipesyntax - index not supported on number" "pipeline $segment_op $initial_returnvarspec $equalsrhs $args" [list pipesyntax index_on_literal] - } - append insertion_script \n {set insertion_data $v} - } else { - #todo - we should potentially group by the variable name and pass as a single call to _multi_bind_result - because stateful @ and @@ won't work in independent calls - append insertion_script \n [string map [list $cmdname] { - #puts ">>> v: $v dict_tagval:'$dict_tagval'" - if {$v eq ""} { - set v "data" - } - if {[dict exists $dict_tagval $v]} { - set insertion_data [dict get $dict_tagval $v] - #todo - use destructure_func - set d [punk::_multi_bind_result $indexspec $insertion_data] - set insertion_data [punk::_handle_bind_result $d] - } else { - #review - skip error if varname is 'data' ? - #e.g we shouldn't really fail for: - #.=>* list a b c <| - #??? Technically - #we need to be careful not to insert empty-list as an argument by default - error "pipevariable - varname $v not present in pipeline context. pipecontext_vars: [dict keys $dict_tagval] (2)" " pipecontext_vars: [dict keys $dict_tagval]" [list pipevariable variable_not_in_pipeline_scope] - } - - }] - } - - - - - #append script [string map [list $getv]{ - # - #}] - #maintenance - index logic should be similar identical? to to match_assign - which only needs to process atoms because it (for now?) delegates all pipeline ops here, so no vars available (single segment assign) - #tag: positionspechandler - - - #puts stdout "=== list_insertion_script '$positionspec' segmenttail " - set script2 [punk::list_insertion_script $positionspec segmenttail ] - set script2 [string map [list "\$insertion_data" ] $script2] - append insertion_script \n $script2 - - } - append insertion_script \n {set segmenttail} - append insertion_script \n "}" - #puts stderr "$insertion_script" - debug.punk.pipe.compile {creating proc ::punk::pipecmds::insertion::_$rhsmapped } 4 - eval $insertion_script - } - - set segment_members_filled [::punk::pipecmds::insertion::_$rhsmapped $dict_tagval [lindex [list $segmenttail [unset segmenttail]] 0] ] - - #set segment_members_filled $segmenttail - #note - length of segment_members_filled may now differ from length of original segment_members! (if do_expand i.e trailing * in any insertion_patterns) - - } - set rhs [string map $dict_tagval $rhs] ;#obsolete? - - debug.punk.pipe.rep {segment_members_filled rep: [rep $segment_members_filled]} 4 - - - # script index could have changed!!! todo fix! - - #we require re_dot_assign before re_assign (or fix regexes so order doesn't matter!) - if {(!$segment_first_is_script ) && $segment_op eq ".="} { - #no scriptiness detected - - #debug.punk.pipe.rep {[a yellow bold][rep_listname segment_members_filled][a]} 4 - - set cmdlist_result [uplevel 1 $segment_members_filled] - #debug.punk.pipe {[a green bold]forward_result: $forward_result[a]} 4 - #debug.punk.pipe.rep {[a yellow bold]forward_result REP: [rep $forward_result][a]} 4 - - #set d [_multi_bind_result $returnvarspec [punk::K $cmdlist_result [unset cmdlist_result]]] - set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result ]] 0]] - - set segment_result [_handle_bind_result $d] - #puts stderr ">>forward_result: $forward_result segment_result $segment_result" - - - } elseif {$segment_op eq "="} { - #slightly different semantics for assigment! - #We index into the DATA - not the position within the segment! - #(an = segment must take a single argument, as opposed to a .= segment) - #(This was a deliberate design choice for consistency with set, and to reduce errors.) - #(we could have allowed multiple args to = e.g to form a list, but it was tried, and the edge-cases were unintuitive and prone to user error) - #(The choice to restrict to single argument, but allow insertion and appending via insertion-specs is more explicit and reliable even though the insertion-specs operate differently to those of .=) - # - #we have to ensure that for an empty segment - we don't append to the empty list, thus listifying the data - #v= {a b c} |> = - # must return: {a b c} not a b c - # - if {!$segment_has_insertions} { - set segment_members_filled $segment_members - if {[dict exists $dict_tagval data]} { - if {![llength $segment_members_filled]} { - set segment_members_filled [dict get $dict_tagval data] - } else { - lappend segment_members_filled [dict get $dict_tagval data] - } - } - } - - set d [_multi_bind_result $returnvarspec [lindex [list $segment_members_filled [unset segment_members_filled ]] 0]] - set segment_result [_handle_bind_result $d] - - - } elseif {$segment_first_is_script || $segment_op eq "script"} { - #script - debug.punk.pipe {[a+ cyan bold].. evaluating as script[a]} 2 - - set script [lindex $segment_members 0] - - #build argument lists for 'apply' - set segmentargnames [list] - set segmentargvals [list] - foreach {k val} $dict_tagval { - if {$k eq "args"} { - #skip args - it is manually added at the end of the apply list if it's a valid tcl list - continue - } - lappend segmentargnames $k - lappend segmentargvals $val - } - - set argsdatalist $prevr ;#default is raw result as a list. May be overridden by an argspec within |> e.g |args@@key> or stripped if not a tcl list - #puts "------> rep prevr argsdatalist: [rep $argsdatalist]" - set add_argsdata 0 - if {[dict exists $dict_tagval "args"]} { - set argsdatalist [dict get $dict_tagval "args"] - #see if the raw result can be treated as a list - if {[catch {lindex $argsdatalist 0}]} { - #we cannot supply 'args' - set pre_script "" - #todo - only add trace if verbose warnings enabled? - append pre_script "trace add variable args read punk::pipeline_args_read_trace_error\n" - set script $pre_script - append script $segment_first_word - set add_argsdata 0 - } else { - set add_argsdata 1 - } - } - - debug.punk.pipe.rep {>> [rep_listname segmentargvals]} 4 - set ns [uplevel 1 {::namespace current}] - if {!$add_argsdata} { - debug.punk.pipe {APPLY1: (args not set; not a list) segment vars:$segmentargnames} 4 - #puts stderr " script: $script" - #puts stderr " vals: $segmentargvals" - set evaluation [uplevel 1 [list ::apply [::list $segmentargnames $script $ns] {*}$segmentargvals]] - } else { - debug.punk.pipe {APPLY2: (args is set)segment vars:$segmentargnames} 4 - #puts stderr " script: $script" - #puts stderr " vals: $segmentargvals $argsdatalist" - #pipeline script context should be one below calling context - so upvar v v will work - #ns with leading colon will fail with apply - set evaluation [uplevel 1 [list ::apply [::list [::concat $segmentargnames args] $script $ns] {*}$segmentargvals {*}$argsdatalist]] - } - - debug.punk.pipe.rep {script result, evaluation: [rep_listname evaluation]} 4 - #puts "---> rep script evaluation result: [rep $evaluation]" - #set d [_multi_bind_result $returnvarspec [punk::K $evaluation [unset evaluation]]] - - #trailing segment_members are *pipedata* scripts - as opposed to ordinary pipeline scripts! - set tail_scripts [lrange $segment_members 1 end] - if {[llength $tail_scripts]} { - set r [pipedata $evaluation {*}$tail_scripts] - } else { - set r $evaluation - } - set d [_multi_bind_result $returnvarspec [lindex [list $r [unset r]] 0]] - set segment_result [_handle_bind_result $d] - } else { - #tags ? - #debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5 - if {false} { - #set s [list uplevel 1 [concat $rhs $segment_members_filled]] - if {![info exists pscript]} { - upvar ::_pipescript pscript - } - if {![info exists pscript]} { - #set pscript $s - set pscript [funcl::o_of_n 1 $segment_members] - } else { - #set pscript [string map [list

$pscript] {uplevel 1 [concat $rhs $segment_members_filled [

]]}] - #set snew "set pipe_$i \[uplevel 1 \[list $rhs $segment_members_filled " - #append snew "set pipe_[expr $i -1]" - #append pscript $snew - set pscript [funcl::o_of_n 1 $segment_members $pscript] - - } - } - - set cmdlist_result [uplevel 1 $segment_members_filled] - #set d [_multi_bind_result $returnvarspec [punk::K $segment_members_filled [unset segment_members_filled]]] - set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result]] 0 ]] - - #multi_bind_result needs to return a funcl for rhs of: - #lindex [list [set syncvar [main pipeline.. ]] [rhs binding funcl...] 1 ] - #which uses syncvar - # - #The lhs of 'list' runs first so now syncvar can be the root level of the rhs function list and bind the necessary vars. - #NOTE: unintuitively, we are returning the value of rhs to the main pipleline! (leftmost binding) this is because the leftmost binding determines what goes back to the pipeline result - - set segment_result [_handle_bind_result $d] - } - #the subresult doesn't need to go backwards - as the final assignment can emit the result into a variable - #It makes more sense and is ultimately more useful (and more easy to reason about) for the result of each assignment to be related only to the pre-pipe section - #It may however make a good debug point - #puts stderr "segment $i segment_result:$segment_result" - - debug.punk.pipe.rep {[rep_listname segment_result]} 3 - - - - - - #examine tailremaining. - # either x x x |?> y y y ... - # or just y y y - #we want the x side for next loop - - #set up the conditions for the next loop - #|> x=y args - # inpipespec - contents of previous piper |xxx> - # outpipespec - empty or content of subsequent piper |xxx> - # previous_result - # assignment (x=y) - - - set pipespec($j,in) $pipespec($i,out) - set outpipespec "" - set tailmap "" - set next_pipe_posn -1 - if {[llength $tailremaining]} { - - #set tailmap [lmap v $tailremaining {lreplace [split $v {}] 1 end-1}] - ##e.g for: a b c |> e f g |> h - #set next_pipe_posn [lsearch $tailmap {| >}] - set next_pipe_posn [lsearch $tailremaining "|*>"] - - set outpipespec [string range [lindex $tailremaining $next_pipe_posn] 1 end-1] - } - set pipespec($j,out) $outpipespec - - - set script_like_first_word 0 - if {[llength $tailremaining] || $next_pipe_posn >= 0} { - - if {$next_pipe_posn >=0} { - set next_all_members [lrange $tailremaining 0 $next_pipe_posn-1] ;#exclude only piper |xxx> for - set tailremaining [lrange $tailremaining $next_pipe_posn+1 end] - - } else { - set next_all_members $tailremaining - set tailremaining [list] - } - - - #assignment is the arg immediately following |> operator e.g x.=blah or x=etc (or a normal commandlist or script!) - set segment_first_word "" - set returnvarspec "" ;# the lhs of x=y - set segment_op "" - set rhs "" - set segment_first_is_script 0 - if {[llength $next_all_members]} { - if {[punk::pipe::lib::arg_is_script_shaped [lindex $next_all_members 0]]} { - set segment_first_word [lindex $next_all_members 0] - set segment_first_is_script 1 - set segment_op "" - set segment_members $next_all_members - } else { - set possible_assignment [lindex $next_all_members 0] - #set re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} - if {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} $possible_assignment _ returnvarspec rhs]} { - set segment_op ".=" - set segment_first_word [lindex $next_all_members 1] - set script_like_first_word [punk::pipe::lib::arg_is_script_shaped $segment_first_word] - if {$script_like_first_word} { - set segment_first_is_script 1 ;#relative to segment_members which no longer includes the .= - } - set segment_members [lrange $next_all_members 1 end] - } elseif {[regexp {^([^ \t\r\n=]*)=(.*)} $possible_assignment _ returnvarspec rhs]} { - set segment_op "=" - #never scripts - #must be at most a single element after the = ! - if {[llength $next_all_members] > 2} { - #raise this as pipesyntax as opposed to pipedata? - error "pipesyntax - at most one element can follow = (got [lrange $next_all_members 1 end])" "pipeline $segment_op $returnvarspec $rhs [lrange $next_all_members 1 end]" [list pipesyntax too_many_elements] - } - set segment_first_word [lindex $next_all_members 1] - if {[catch {llength $segment_first_word}]} { - set segment_is_list 0 ;#only used for segment_op = - } else { - set segment_is_list 1 ;#only used for segment_op = - } - - set segment_members $segment_first_word - } else { - #no assignment operator and not script shaped - set segment_op "" - set returnvarspec "" - set segment_first_word [lindex $next_all_members 0] - set segment_first_word [lindex $next_all_members 1] - set segment_members $next_all_members - #puts stderr ">>3 no-operator segment_first_word: '$segment_first_word'" - } - } - - - } else { - #?? two pipes in a row ? - debug.punk.pipe {[a+ yellow bold]WARNING: no segment members found[a]} 0 - set segment_members return - set segment_first_word return - } - - #set forward_result $segment_result - #JMN2 - set previous_result $segment_result - #set previous_result [join $segment_result] - } else { - debug.punk.pipe {[a+ cyan bold]End of pipe segments ($i)[a]} 4 - #output pipe spec at tail of pipeline - - set pipedvars [dict create] - if {[string length $pipespec($i,out)]} { - set d [apply {{mv res} { - punk::_multi_bind_result $mv $res -levelup 1 - }} $pipespec($i,out) $segment_result] - set segment_result [_handle_bind_result $d] - set pipedvars [dict get $d setvars] - } - - set more_pipe_segments 0 - } - - #the segment_result is based on the leftmost var on the lhs of the .= - #whereas forward_result is always the entire output of the segment - #JMN2 - #lappend segment_result_list [join $segment_result] - lappend segment_result_list $segment_result - incr i - incr j - } ;# end while - - return [lindex $segment_result_list end] - #JMN2 - #return $segment_result_list - #return $forward_result - } - - - #just an experiment - #what advantage/difference versus [llength [lrange $data $start $end]] ??? - proc data_range_length {data start end} { - set datalen [llength $data] - - #normalize to s and e - if {$start eq "end"} { - set s [expr {$datalen - 1}] - } elseif {[string match end-* $start]} { - set stail [string range $start 4 end] - set posn [expr {$datalen - $stail -1}] - if {$posn < 0} { - return 0 - } - set s $posn - } else { - #int - if {($start < 0) || ($start > ($datalen -1))} { - return 0 - } - set s $start - } - if {$end eq "end"} { - set e [expr {$datalen - 1}] - } elseif {[string match end-* $end]} { - set etail [string range $end 4 end] - set posn [expr {$datalen - $etail -1}] - if {$posn < 0} { - return 0 - } - set e $posn - } else { - #int - if {($end < 0)} { - return 0 - } - set e $end - } - if {$s > ($datalen -1)} { - return 0 - } - if {$e > ($datalen -1)} { - set e [expr {$datalen -1}] - } - - - - if {$e < $s} { - return 0 - } - - return [expr {$e - $s + 1}] - } - - # unknown -- - # This procedure is called when a Tcl command is invoked that doesn't - # exist in the interpreter. It takes the following steps to make the - # command available: - # - # 1. See if the autoload facility can locate the command in a - # Tcl script file. If so, load it and execute it. - # 2. If the command was invoked interactively at top-level: - # (a) see if the command exists as an executable UNIX program. - # If so, "exec" the command. - # (b) see if the command requests csh-like history substitution - # in one of the common forms !!, !, or ^old^new. If - # so, emulate csh's history substitution. - # (c) see if the command is a unique abbreviation for another - # command. If so, invoke the command. - # - # Arguments: - # args - A list whose elements are the words of the original - # command, including the command name. - - #review - we shouldn't really be doing this - #We need to work out if we can live with the real default unknown and just inject some special cases at the beginning before falling-back to the normal one - - proc ::unknown args { - #puts stderr "unk>$args" - variable ::tcl::UnknownPending - global auto_noexec auto_noload env tcl_interactive errorInfo errorCode - - if {[info exists errorInfo]} { - set savedErrorInfo $errorInfo - } - if {[info exists errorCode]} { - set savedErrorCode $errorCode - } - - set name [lindex $args 0] - if {![info exists auto_noload]} { - # - # Make sure we're not trying to load the same proc twice. - # - if {[info exists UnknownPending($name)]} { - return -code error "self-referential recursion\ - in \"unknown\" for command \"$name\"" - } - set UnknownPending($name) pending - set ret [catch { - auto_load $name [uplevel 1 {::namespace current}] - } msg opts] - unset UnknownPending($name) - if {$ret != 0} { - dict append opts -errorinfo "\n (autoloading \"$name\")" - return -options $opts $msg - } - if {![array size UnknownPending]} { - unset UnknownPending - } - if {$msg} { - if {[info exists savedErrorCode]} { - set ::errorCode $savedErrorCode - } else { - unset -nocomplain ::errorCode - } - if {[info exists savedErrorInfo]} { - set errorInfo $savedErrorInfo - } else { - unset -nocomplain errorInfo - } - set code [catch {uplevel 1 $args} msg opts] - if {$code == 1} { - # - # Compute stack trace contribution from the [uplevel]. - # Note the dependence on how Tcl_AddErrorInfo, etc. - # construct the stack trace. - # - set errInfo [dict get $opts -errorinfo] - set errCode [dict get $opts -errorcode] - set cinfo $args - if {[string length [encoding convertto utf-8 $cinfo]] > 150} { - set cinfo [string range $cinfo 0 150] - while {[string length [encoding convertto utf-8 $cinfo]] > 150} { - set cinfo [string range $cinfo 0 end-1] - } - append cinfo ... - } - set tail "\n (\"uplevel\" body line 1)\n invoked\ - from within\n\"uplevel 1 \$args\"" - set expect "$msg\n while executing\n\"$cinfo\"$tail" - if {$errInfo eq $expect} { - # - # The stack has only the eval from the expanded command - # Do not generate any stack trace here. - # - dict unset opts -errorinfo - dict incr opts -level - return -options $opts $msg - } - # - # Stack trace is nested, trim off just the contribution - # from the extra "eval" of $args due to the "catch" above. - # - set last [string last $tail $errInfo] - if {$last + [string length $tail] != [string length $errInfo]} { - # Very likely cannot happen - return -options $opts $msg - } - set errInfo [string range $errInfo 0 $last-1] - set tail "\"$cinfo\"" - set last [string last $tail $errInfo] - if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} { - return -code error -errorcode $errCode \ - -errorinfo $errInfo $msg - } - set errInfo [string range $errInfo 0 $last-1] - set tail "\n invoked from within\n" - set last [string last $tail $errInfo] - if {$last + [string length $tail] == [string length $errInfo]} { - return -code error -errorcode $errCode \ - -errorinfo [string range $errInfo 0 $last-1] $msg - } - set tail "\n while executing\n" - set last [string last $tail $errInfo] - if {$last + [string length $tail] == [string length $errInfo]} { - return -code error -errorcode $errCode \ - -errorinfo [string range $errInfo 0 $last-1] $msg - } - return -options $opts $msg - } else { - dict incr opts -level - return -options $opts $msg - } - } - } - #set isrepl [expr {[file tail [file rootname [info script]]] eq "repl"}] - set isrepl [punk::repl::codethread::is_running] ;#may not be reading though - if {$isrepl} { - #set ::tcl_interactive 1 - } - if {$isrepl || (([info level] == 1) && (([info script] eq "" ) ) - && ([info exists tcl_interactive] && $tcl_interactive))} { - if {![info exists auto_noexec]} { - set new [auto_execok $name] - if {$new ne ""} { - set redir "" - if {[namespace which -command console] eq ""} { - set redir ">&@stdout <@stdin" - } - - - #windows experiment todo - use twapi and named pipes - #twapi::namedpipe_server {\\.\pipe\something} - #Then override tcl 'exec' and replace all stdout/stderr/stdin with our fake ones - #These can be stacked with shellfilter and operate as OS handles - which we can't do with fifo2 etc - # - - if {[string first " " $new] > 0} { - set c1 $name - } else { - set c1 $new - } - - # -- --- --- --- --- - set idlist_stdout [list] - set idlist_stderr [list] - #set shellrun::runout "" - #when using exec with >&@stdout (to ensure process is connected to console) - the output unfortunately doesn't go via the shellfilter stacks - #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] - #lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] - - if {[punk::config::configure running auto_exec_mechanism] eq "experimental"} { - #TODO - something cross-platform that allows us to maintain a separate console(s) with an additional set of IO channels to drive it - #not a trivial task - - #This runs external executables in a context in which they are not attached to a terminal - #VIM for example won't run, and various programs can't detect terminal dimensions etc and/or will default to ansi-free output - #ctrl-c propagation also needs to be considered - - set teehandle punksh - uplevel 1 [list ::catch \ - [list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle $teehandle -inbuffering line -outbuffering none ] \ - ::tcl::UnknownResult ::tcl::UnknownOptions] - - if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} { - dict set ::tcl::UnknownOptions -code error - set ::tcl::UnknownResult "Non-zero exit code from command '$args' $::tcl::UnknownResult" - } else { - #no point returning "exitcode 0" if that's the only non-error return. - #It is misleading. Better to return empty string. - set ::tcl::UnknownResult "" - } - } else { - set repl_runid [punk::get_repl_runid] - #set ::punk::last_run_display [list] - - set redir ">&@stdout <@stdin" - uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] - #we can't detect stdout/stderr output from the exec - #for now emit an extra \n on stderr - #todo - there is probably no way around this but to somehow exec in the context of a completely separate console - #This is probably a tricky problem - especially to do cross-platform - # - # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit - if {[dict get $::tcl::UnknownOptions -code] == 0} { - set c green - set m "ok" - } else { - set c yellow - set m "errorCode $::errorCode" - } - set chunklist [list] - lappend chunklist [list "info" "[a $c]$m[a] " ] - if {$repl_runid != 0} { - tsv::lappend repl runchunks-$repl_runid {*}$chunklist - } - - } - - foreach id $idlist_stdout { - shellfilter::stack::remove stdout $id - } - foreach id $idlist_stderr { - shellfilter::stack::remove stderr $id - } - # -- --- --- --- --- - - - #uplevel 1 [list ::catch \ - # [concat exec $redir $new [lrange $args 1 end]] \ - # ::tcl::UnknownResult ::tcl::UnknownOptions] - - #puts "===exec with redir:$redir $::tcl::UnknownResult ==" - dict incr ::tcl::UnknownOptions -level - return -options $::tcl::UnknownOptions $::tcl::UnknownResult - } - } - - if {$name eq "!!"} { - set newcmd [history event] - } elseif {[regexp {^!(.+)$} $name -> event]} { - set newcmd [history event $event] - } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} { - set newcmd [history event -1] - catch {regsub -all -- $old $newcmd $new newcmd} - } - if {[info exists newcmd]} { - tclLog $newcmd - history change $newcmd 0 - uplevel 1 [list ::catch $newcmd \ - ::tcl::UnknownResult ::tcl::UnknownOptions] - dict incr ::tcl::UnknownOptions -level - return -options $::tcl::UnknownOptions $::tcl::UnknownResult - } - - set ret [catch {set candidates [info commands $name*]} msg] - if {$name eq "::"} { - set name "" - } - if {$ret != 0} { - dict append opts -errorinfo \ - "\n (expanding command prefix \"$name\" in unknown)" - return -options $opts $msg - } - # Filter out bogus matches when $name contained - # a glob-special char [Bug 946952] - if {$name eq ""} { - # Handle empty $name separately due to strangeness - # in [string first] (See RFE 1243354) - set cmds $candidates - } else { - set cmds [list] - foreach x $candidates { - if {[string first $name $x] == 0} { - lappend cmds $x - } - } - } - - #punk - disable prefix match search - set default_cmd_search 0 - if {$default_cmd_search} { - if {[llength $cmds] == 1} { - uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ - ::tcl::UnknownResult ::tcl::UnknownOptions] - dict incr ::tcl::UnknownOptions -level - return -options $::tcl::UnknownOptions $::tcl::UnknownResult - } - if {[llength $cmds]} { - return -code error "ambiguous command name \"$name\": [lsort $cmds]" - } - } else { - #punk hacked version - report matches but don't run - if {[llength $cmds]} { - return -code error "unknown command name \"$name\": possible match(es) [lsort $cmds]" - } - - } - - - } - return -code error -errorcode [list TCL LOOKUP COMMAND $name] "invalid command name $name" - } - - proc know {cond body} { - set existing [info body ::unknown] - #assuming we can't test on cond being present in existing unknown script - because it may be fairly simple and prone to false positives (?) - ##This means we can't have 2 different conds with same body if we test for body in unknown. - ##if {$body ni $existing} { - set scr [base64::encode -maxlen 0 $cond] ;#will only be decoded if the debug is triggered - #tcllib has some double-substitution going on.. base64 seems easiest and will not impact the speed of normal execution when debug off. - - #tclint-disable-next-line - proc ::unknown {args} [string map [list @c@ $cond @b@ $body @scr@ $scr] { - #--------------------------------------- - if {![catch {expr {@c@}} res] && $res} { - debug.punk.unknown {HANDLED BY: punk unknown_handler ([llength $args]) args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 - return [eval {@b@}] - } else { - debug.punk.unknown {skipped: punk unknown_handler ([llength $args]) args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 - } - #--------------------------------------- - }]$existing - #} - } - - proc know? {{len 2000}} { - puts [string range [info body ::unknown] 0 $len] - } - proc decodescript {b64} { - if {[ catch { - base64::decode $b64 - } scr]} { - return "" - } else { - return "($scr)" - } - } - - # --------------------------- - # commands that should be aliased in safe interps that need to use punk repl - # - proc get_repl_runid {} { - if {[interp issafe]} { - if {[info commands ::tsv::exists] eq ""} { - puts stderr "punk::get_repl_runid cannot operate directly in safe interp - install the appropriate punk aliases" - error "punk::get_repl_runid punk repl aliases not installed" - } - #if safe interp got here - there must presumably be a direct set of aliases on tsv::* commands - } - if {[tsv::exists repl runid]} { - return [tsv::get repl runid] - } else { - return 0 - } - } - #ensure we don't get into loop in unknown when in safe interp - which won't have tsv - proc set_repl_last_unknown {args} { - if {[interp issafe]} { - if {[info commands ::tsv::set] eq ""} { - puts stderr "punk::set_repl_last_unknown cannot operate directly in safe interp - install an alias to tsv::set repl last_unknown" - return - } - #tsv::* somehow working - possibly custom aliases for tsv functionality ? review - } - if {[info commands ::tsv::set] eq ""} { - puts stderr "set_repl_last_unknown - tsv unavailable!" - return - } - tsv::set repl last_unknown {*}$args - } - # --------------------------- - - #---------------- - #for var="val {a b c}" - #proc ::punk::val {{v {}}} {tailcall lindex $v} - #proc ::punk::val {{v {}}} {return $v} ;#2023 - approx 2x faster than the tailcall lindex version - - proc ::punk::val [list [list v [purelist]]] {return $v} - #---------------- - - proc configure_unknown {} { - #----------------------------- - #these are critical e.g core behaviour or important for repl displaying output correctly - - - #can't use know - because we don't want to return before original unknown body is called. - proc ::unknown {args} [string cat { - #set ::punk::last_run_display [list] - #set ::repl::last_unknown [lindex $args 0] ;#jn - #tsv::set repl last_unknown [lindex $args 0] ;#REVIEW - punk::set_repl_last_unknown [lindex $args 0] - }][info body ::unknown] - - - #handle process return dict of form {exitcode num etc blah} - #ie when the return result as a whole is treated as a command - #exitcode must be the first key - know {[lindex $args 0 0] eq "exitcode"} { - uplevel 1 [list exitcode {*}[lrange [lindex $args 0] 1 end]] - } - - - #----------------------------- - # - # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. - - #todo - repl output info that it was evaluated as an expression - #know {[expr $args] || 1} {expr $args} - know {[expr $args] || 1} {tailcall expr $args} - - #it is significantly faster to call a proc such as punk::lib::range like this than to inline it in the unknown proc - #punk::lib::range is defined as a wrapper to lseq if it is available (8.7+) - know {[regexp {^([+-]*[0-9_]+)\.\.([+-]*[0-9_]+)$} [lindex $args 0 0] -> from to]} {punk::lib::range $from $to} - - - #NOTE: - #we don't allow setting namespace qualified vars in the lhs assignment pattern. - #The principle is that we shouldn't be setting vars outside of the immediate calling scope. - #(It would also be difficult and error-prone and generally make the pipelines less re-usable and reliable) - #Therefore ::nswhatever::blah= x is the pipeline: blah= x - where the corresponding command, if any is first resolved in ::nswhatever - #We will require that the namespace already exists - which is consistent with if the command were to be run without unknown - proc ::punk::_unknown_assign_dispatch {matchedon pattern equalsrhs args} { - set tail [lassign $args hd] - #puts "-> _unknown_assign_dispatch '$partzerozero' pattern:'$pattern' equalsrhs:'$equalsrhs' args:'$args' argshd:'$hd' argstail:'$tail'" - if {$hd ne $matchedon} { - if {[llength $tail]} { - error "unknown_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $tail" - } - #regexp $punk::re_assign $hd _ pattern equalsrhs - #we assume the whole pipeline has been provided as the head - #regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs tail - regexp {^([^\t\r\n=]*)\=([^\r\n]*)} $hd _ pattern fullrhs - lassign [punk::pipe::lib::_rhs_tail_split $fullrhs] equalsrhs tail - } - #NOTE: - it doesn't make sense to call 'namespace' qualifiers or 'namespace tail' on a compound hd such as v,::etc= blah - # we only look at leftmost namespace-like thing and need to take account of the pattern syntax - # e.g for ::etc,'::x'= - # the ns is :: and the tail is etc,'::x'= - # (Tcl's namespace qualifiers/tail won't help here) - if {[string match ::* $hd]} { - set patterns [punk::pipe::lib::_split_patterns_memoized $hd] - #get a pair-list something like: {::x /0} {etc {}} - set ns [namespace qualifiers [lindex $patterns 0 0]] - set nslen [string length $ns] - set patterntail [string range $ns $nslen end] - } else { - set ns "" - set patterntail $pattern - } - if {[string length $ns] && ![namespace exists $ns]} { - error "unknown_assign_dispatch: namespace '$ns' not found. (Note that pipeline lhs variables cannot be namespaced)" - } else { - set nscaller [uplevel 1 [list ::namespace current]] - #jmn - set rhsmapped [punk::pipe::lib::pipecmd_namemapping $equalsrhs] - set commands [uplevel 1 [list ::info commands $pattern=$rhsmapped]] ;#uplevel - or else we are checking from perspective of this namespace ::punk - #we must check for exact match of the command in the list - because command could have glob chars. - if {"$pattern=$rhsmapped" in $commands} { - puts stderr "unknown_assign_dispatch>> '$pattern=$equalsrhs' $commands nscaller: '$nscaller'" - #we call the namespaced function - we don't evaluate it *in* the namespace. - #REVIEW - #warn for now...? - #tailcall $pattern=$equalsrhs {*}$args - tailcall $pattern=$rhsmapped {*}$tail - } - } - #puts "--->nscurrent [uplevel 1 [list ::namespace current]]" - #ignore the namespace.. - #We could interpret the fact that the nonexistant pipe was called with a namespace to indicate that's where the pipecommand should be created.. - #But.. we would need to ensure 1st (compiling) invocation runs the same way as subsequent invocations. - #namespace evaling match_assign here probably wouldn't accomplish that and may create surprises with regards to where lhs vars(if any) are created - tailcall ::punk::match_assign $patterntail $equalsrhs {*}$tail - #return [uplevel 1 [list ::punk::match_assign $varspecs $rhs $tail]] - } - #variable re_assign {^([^\r\n=\{]*)=(.*)} - #characters directly following = need to be assigned to the var even if they are escaped whitespace (e.g \t \r \n) - #unescaped whitespace causes the remaining elements to be part of the tail -ie are appended to the var as a list - #e.g x=a\nb c - #x will be assigned the list {a\nb c} ie the spaces between b & c are not maintained - # - #know {[regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} - #know {[regexp {^{([^\t\r\n=]*)\=([^ \t\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} - - - - proc ::punk::_unknown_compare {val1 val2 args} { - if {![string length [string trim $val2]]} { - if {[llength $args] > 1} { - #error "Extra args after comparison operator ==. usage e.g : \$var1==\$var2 or \$var1==\$var2 + 2" - set val2 [string cat {*}[lrange $args 1 end]] - return [expr {$val1 eq $val2}] - } - return $val1 - } elseif {[llength $args] == 1} { - #simple comparison - if {[string is digit -strict $val1$val2]} { - return [expr {$val1 == $val2}] - } else { - return [string equal $val1 $val2] - } - } elseif {![catch {expr $val2 {*}[lrange $args 1 end]} evaluated]} { - if {[string is digit -strict $val1$evaluated]} { - return [expr {$val1 == $evaluated}] - } else { - return [expr {$val1 eq $evaluated}] - } - } else { - set evaluated [uplevel 1 [list {*}$val2 {*}[lrange $args 1 end]]] - if {[string is digit -strict $val1$evaluated]} { - return [expr {$val1 == $evaluated}] - } else { - return [expr {$val1 eq $evaluated}] - } - } - } - #ensure == is after = in know sequence - #.* on left is pretty broad - todo: make it a little more specific to avoid unexpected interactions - know {[regexp {(.*)==(.*)} [lindex $args 0] _ val1 val2]} {tailcall ::punk::_unknown_compare $val1 $val2 {*}$args} - #.= must come after = here to ensure it comes before = in the 'unknown' proc - #set punk::re_dot_assign {([^=]*)\.=(.*)} - #know {[regexp $punk::re_dot_assign [lindex $args 0 0] _ varspecs rhs]} { - # set tail [expr {([lindex $args 0] eq [lindex $args 0 0]) ? [lrange $args 1 end] : [concat [lrange [lindex $args 0] 1 end] [lrange $args 1 end] ] }] - # tailcall ::punk::match_exec $varspecs $rhs {*}$tail - # #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] - # } - # - - - - proc ::punk::_unknown_dot_assign_dispatch {partzerozero pattern equalsrhs args} { - #puts stderr ". unknown dispatch $partzerozero" - set argstail [lassign $args hd] - - #this equates to auto-flattening the head.. which seems like a bad idea, the structure was there for a reason. - #we should require explicit {*} expansion if the intention is for the args to be joined in at that level. - #expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } - - if {$hd ne $partzerozero} { - if {[llength $argstail]} { - error "unknown_dot_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $argstail" - } - #regexp $punk::re_assign $hd _ pattern equalsrhs - #we assume the whole pipeline has been provided as the head - #regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail - #regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail - - regexp {^([^ \t\r\n=\{]*)\.=([^\r\n]*)} $hd _ pattern fullrhs - lassign [punk::pipe::lib::_rhs_tail_split $fullrhs] equalsrhs argstail - } - #tailcall ::punk::match_assign $pattern $equalsrhs {*}$argstail - - - return [uplevel 1 [list ::punk::pipeline .= $pattern $equalsrhs {*}$argstail]] - - } - - # - know {[regexp {^([^\t\r\n=]*)\=([^\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} - know {[regexp {^{([^\t\r\n=]*)\=([^\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} - - #variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} - #know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} - #know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} - #know {[regexp {^([^\t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} - #know {[regexp {^([^\t\r\n=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} - know {[regexp {^([^=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} - - #add escaping backslashes to a value - #matching odd keys in dicts using pipeline syntax can be tricky - as - #e.g - #set ktest {a"b} - #@@[escv $ktest].= list a"b val - #without escv: - #@@"a\\"b".= list a"b val - #with more backslashes in keys the escv use becomes more apparent: - #set ktest {\\x} - #@@[escv $ktest].= list $ktest val - #without escv we would need: - #@@\\\\\\\\x.= list $ktest val - proc escv {v} { - #https://stackoverflow.com/questions/11135090/is-there-any-tcl-function-to-add-escape-character-automatically - #thanks to DKF - regsub -all {\W} $v {\\&} - } - interp alias {} escv {} punk::escv - #review - #set v "\u2767" - # - #escv $v - #\ - #the - - - #know {[regexp $punk::re_dot_assign [lindex $args 0 0] partzerozero varspecs rhs]} { - # set argstail [lassign $args hd] - # #set tail [expr {($hd eq $partzerozero) ? $argstail : [concat [lrange $hd 1 end] $argstail ] }] ;#!WRONG. expr will convert some numbers to scientific notation - this is premature/undesirable! - # #avoid using the return from expr and it works: - # expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } - # - # tailcall ::punk::match_exec $varspecs $rhs {*}$tail - # #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] - #} - - } - configure_unknown - #if client redefines 'unknown' after package require punk, they must call punk::configure_unknown afterwards. - # - - #main Pipe initiator function - needed especially if 'unknown' not configured to interpret x.= x= etc - #Should theoretically be slightly faster.. but pipelines are relatively slow until we can get pipeline compiling and optimisation. - proc % {args} { - set arglist [lassign $args assign] ;#tail, head - if {$assign eq ".="} { - tailcall {*}[list ::punk::pipeline .= "" "" {*}$arglist] - } elseif {$assign eq "="} { - tailcall {*}[list ::punk::pipeline = "" "" {*}$arglist] - } - - set is_script [punk::pipe::lib::arg_is_script_shaped $assign] - - if {!$is_script && [string index $assign end] eq "="} { - #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} - #set dumbeditor {\}} - #set re_equals {^([^ \t\r\n=\{]*)=$} - #set dumbeditor {\}} - if {[regexp {^([^ \t\r\n=\{]*)\.=$} $assign _ returnvarspecs]} { - set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] - } elseif {[regexp {^([^ \t\r\n=\{]*)=$} $assign _ returnvarspecs]} { - set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] - } else { - error "pipesyntax punk::% unable to interpret pipeline '$args'" "% $args" [list pipesyntax unable_to_interpret] - } - } else { - if {$is_script} { - set cmdlist [list ::punk::pipeline "script" "" "" {*}$args] - } else { - set cmdlist [list ::punk::pipeline ".=" "" "" {*}$args] - } - } - tailcall {*}$cmdlist - - - #result-based mismatch detection can probably never work nicely.. - #we need out-of-band method to detect mismatch. Otherwise we can't match on mismatch results! - # - set result [uplevel 1 $cmdlist] - #pipeline result not guaranteed to be a proper list so we can't use list methods to directly look for 'binding mismatch' - #.. but if we use certain string methods - we shimmer the case where the main result is a list - #string match doesn't seem to change the rep.. though it does generate a string rep. - #puts >>1>[rep $result] - if {[catch {lrange $result 0 1} first2wordsorless]} { - #if we can't get as a list then it definitely isn't the semi-structured 'binding mismatch' - return $result - } else { - if {$first2wordsorless eq {binding mismatch}} { - error $result - } else { - #puts >>2>[rep $result] - return $result - } - } - } - - proc ispipematch {args} { - expr {[lindex [uplevel 1 [list pipematch {*}$args]] 0] eq "ok"} - } - - #pipe initiator which will never raise an error *except for pipesyntax* , but always returns {ok {result something}} or {error {mismatch something}} or, for tcl errors {error {reason something}} - proc pipematch {args} { - #debug.punk.pipe {pipematch level [info level] levelinfo [info level 0]} 2 - variable re_dot_assign - variable re_assign - - set arglist [lassign $args assign] - if {$assign eq ".="} { - set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] - } elseif {$assign eq "="} { - set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] - } elseif {![punk::pipe::lib::arg_is_script_shaped $assign] && [string index $assign end] eq "="} { - #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} - # set dumbeditor {\}} - #set re_equals {^([^ \t\r\n=\{]*)=$} - # set dumbeditor {\}} - if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { - set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] - } elseif {[regexp {^([^ \t\r\n=]*)=.*} $assign _ returnvarspecs]} { - set cmdlist [list $assign {*}$arglist] - #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] - } else { - error "pipesyntax punk::pipematch unable to interpret pipeline '$args'" "pipematch $args" [pipesyntax unable_to_interpret] - } - } else { - set cmdlist $args - #script? - #set cmdlist [list ::punk::pipeline .= "" "" {*}$args] - } - - if {[catch {uplevel 1 $cmdlist} result erroptions]} { - #puts stderr "pipematch erroptions:$erroptions" - #debug.punk.pipe {pipematch error $result} 4 - set ecode [dict get $erroptions -errorcode] - switch -- [lindex $ecode 0] { - binding { - if {[lindex $ecode 1] eq "mismatch"} { - #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch - #return [dict create error [dict create mismatch $result]] - #puts stderr "pipematch converting error to {error {mismatch }}" - return [list error [list mismatch $result]] - } - } - pipesyntax { - #error $result - return -options $erroptions $result - } - casematch { - return $result - } - } - #return [dict create error [dict create reason $result]] - return [list error [list reason $result]] - } else { - return [list ok [list result $result]] - #debug.punk.pipe {pipematch result $result } 4 - #return [dict create ok [dict create result $result]] - } - } - - proc pipenomatchvar {varname args} { - if {[string first = $varname] >=0} { - #first word "pipesyntax" is looked for by pipecase - error "pipesyntax pipenomatch expects a simple varname as first argument" "pipenomatchvar $varname $args" [list pipesyntax expected_simple_varname] - } - #debug.punk.pipe {pipematch level [info level] levelinfo [info level 0]} 2 - - set assign [lindex $args 0] - set arglist [lrange $args 1 end] - if {[string first = $assign] >= 0} { - variable re_dot_assign - variable re_assign - #what if we get passed a script block containing = ?? e.g {error x=a} - if {$assign eq ".="} { - set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] - } elseif {$assign eq "="} { - set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] - } elseif {[regexp $re_dot_assign $assign _ returnvarspecs rhs]} { - set cmdlist [list ::punk::pipeline .= $returnvarspecs $rhs {*}$arglist] - } elseif {[regexp $re_assign $assign _ returnvarspecs rhs]} { - set cmdlist [list ::punk::pipeline = $returnvarspecs $rhs {*}$arglist] - } else { - debug.punk.pipe {[a+ yellow bold] Unexpected arg following pipenomatchvar variable [a]} 0 - set cmdlist $args - #return [dict create error [dict create reason [dict create pipematch bad_first_word value $assign pipeline [list pipematch $assign {*}$args]]]] - } - } else { - set cmdlist $args - } - - upvar 1 $varname nomatchvar - if {[catch {uplevel 1 $cmdlist} result erroptions]} { - set ecode [dict get $erroptions -errorcode] - debug.punk.pipe {[a+ yellow bold]pipematchnomatch error $result[a]} 3 - if {[lindex $ecode 0] eq "pipesyntax"} { - set errordict [dict create error [dict create pipesyntax $result]] - set nomatchvar $errordict - return -options $erroptions $result - } - if {[lrange $ecode 0 1] eq "binding mismatch"} { - #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch - set errordict [dict create error [dict create mismatch $result]] - set nomatchvar $errordict - return -options $erroptions $result - } - set errordict [dict create error [dict create reason $result]] - set nomatchvar $errordict - #re-raise the error for pipeswitch to deal with - return -options $erroptions $result - } else { - debug.punk.pipe {pipematchnomatch result $result } 4 - set nomatchvar "" - #uplevel 1 [list set $varname ""] - #return raw result only - to pass through to pipeswitch - return $result - #return [dict create ok [dict create result $result]] - } - } - - #should only raise an error for pipe syntax errors - all other errors should be wrapped - proc pipecase {args} { - #debug.punk.pipe {pipecase level [info level] levelinfo [info level 0]} 9 - set arglist [lassign $args assign] - if {$assign eq ".="} { - set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] - } elseif {$assign eq "="} { - #set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] - set cmdlist [list ::= {*}$arglist] - } elseif {![punk::pipe::lib::arg_is_script_shaped $assign] && [string first "=" $assign] >= 0} { - #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} - #set dumbeditor {\}} - #set re_equals {^([^ \t\r\n=\{]*)=$} - #set dumbeditor {\}} - - if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { - set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] - } elseif {[regexp {^([^ \t\r\n=]*)=.*} $assign _ returnvarspecs]} { - set cmdlist [list $assign {*}$arglist] - #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] - } else { - error "pipesyntax pipecase unable to interpret pipeline '$args'" - } - #todo - account for insertion-specs e.g x=* x.=/0* - } else { - #script? - set cmdlist [list ::punk::pipeline .= "" "" {*}$args] - } - - - if {[catch {uplevel 1 [list ::if 1 $cmdlist]} result erroptions]} { - #puts stderr "====>>> result: $result erroptions" - set ecode [dict get $erroptions -errorcode] - switch -- [lindex $ecode 0] { - pipesyntax { - #error $result - return -options $erroptions $result - } - casenomatch { - return -options $erroptions $result - } - binding { - if {[lindex $ecode 1] eq "mismatch"} { - #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch - #return [dict create error [dict create mismatch $result]] - # - #NOTE: casemismatch is part of the api for pipecase. It is a casemismatch rather than an error - because for a pipecase - a casemismatch is an expected event (many casemismatches - one match) - return [dict create casemismatch $result] - } - } - } - - #we can't always treat $result as a list - may be an error string which can't be represented as a list, and there may be no useful errorCode - #todo - use errorCode instead - if {[catch {lindex $result 0} word1]} { - #tailcall error $result - return -options $erroptions $result - } else { - switch -- $word1 { - switcherror - funerror { - error $result "pipecase [lsearch -all -inline $args "*="]" - } - resultswitcherror - resultfunerror { - #recast the error as a result without @@ok wrapping - #use the tailcall return to stop processing other cases in the switch! - tailcall return [dict create error $result] - } - ignore { - #suppress error, but use normal return - return [dict create error [dict create suppressed $result]] - } - default { - #normal tcl error - #return [dict create error [dict create reason $result]] - tailcall error $result "pipecase $args" [list caseerror] - } - } - } - } else { - tailcall return -errorcode [list casematch] [dict create ok [dict create result $result]] - } - - } - - #note that pipeswitch deliberately runs in callers scope to have direct access to variables - it is akin to a control structure. - #It also - somewhat unusually accepts args - which we provide as 'switchargs' - #This is unorthodox/risky in that it will clobber any existing var of that name in callers scope. - #Solve using documentation.. consider raising error if 'switchargs' already exists, which would require user to unset switchargs in some circumstances. - proc pipeswitch {pipescript args} { - #set nextargs $args - #unset args - #upvar args upargs - #set upargs $nextargs - upvar switchargs switchargs - set switchargs $args - uplevel 1 [::list ::if 1 $pipescript] - } - #static-closure version - because we shouldn't be writing back to calling context vars directly - #Tcl doesn't (2023) have mutable closures - but for functional pipeline composition - we probably don't want that anyway! - #pipeswitchc is preferable to pipeswitch in that we can access context without risk of affecting it, but is less performant. (particularly in global scope.. but that probably isn't an important usecase) - proc pipeswitchc {pipescript args} { - set binding {} - if {[info level] == 1} { - #up 1 is global - set get_vars [list info vars] - } else { - set get_vars [list info locals] - } - set vars [uplevel 1 {*}$get_vars] - set posn [lsearch $vars switchargs] - set vars [lreplace $vars $posn $posn] - foreach v $vars { - upvar 1 $v var - if {(![array exists var]) && [info exists var]} { - lappend binding [list $v $var] ;#values captured as defaults for apply args. - } - } - lappend binding [list switchargs $args] - apply [list $binding $pipescript [uplevel 1 {::namespace current}]] - } - - proc pipedata {data args} { - #puts stderr "'$args'" - set r $data - for {set i 0} {$i < [llength $args]} {incr i} { - set e [lindex $args $i] - #review: string is list is as slow as catch {llength $e} - and also affects ::errorInfo unlike other string is commands. bug/enhancement report? - if {![string is list $e]} { - #not a list - assume script and run anyway - set r [apply [list {data} $e] $r] - } else { - if {[llength $e] == 1} { - switch -- $e { - > { - #output to calling context. only pipedata return value and '> varname' should affect caller. - incr i - uplevel 1 [list set [lindex $args $i] $r] - } - % - pipematch - ispipematch { - incr i - set e2 [lindex $args $i] - #set body [list $e {*}$e2] - #append body { $data} - - set body [list $e {*}$e2] - append body { {*}$data} - - - set applylist [list {data} $body] - #puts stderr $applylist - set r [apply $applylist $r] - } - pipeswitch - pipeswitchc { - #pipeswitch takes a script not a list. - incr i - set e2 [lindex $args $i] - set body [list $e $e2] - #pipeswitch takes 'args' - so expand $data when in pipedata context - append body { {*}$data} - #use applylist instead of uplevel when in pipedata context! - #can use either switchdata/data but not vars in calling context of 'pipedata' command. - #this is consistent with pipeswitch running in a % / .= pipeline which can only access vars in immediate calling context. - set applylist [list {data} $body] - #puts stderr $applylist - set r [apply $applylist $r] - } - default { - #puts "other single arg: [list $e $r]" - append e { $data} - set r [apply [list {data} $e] $r] - } - } - } elseif {[llength $e] == 0} { - #do nothing - pass data through - #leave r as is. - } else { - set r [apply [list {data} $e] $r] - } - } - } - return $r - } - - - proc scriptlibpath {{shortname {}} args} { - set scriptlib [punk::config::configure running scriptlib] - if {[string match "lib::*" $shortname]} { - set relpath [string map [list "lib::" "" "::" "/"] $shortname] - set relpath [string trimleft $relpath "/"] - set fullpath $scriptlib/$relpath - } else { - set shortname [string trimleft $shortname "/"] - set fullpath $scriptlib/$shortname - } - return $fullpath - } - - - #useful for aliases e.g treemore -> xmore tree - proc xmore {args} { - if {[llength $args]} { - #more is older and not as featureful as less - #more importantly - at least some implementations (msys on windows) can skip output lines - unknown as to why - #uplevel #0 [list {*}$args | more] - uplevel #0 [list {*}$args | less -X] ;#-X to avoid use of alternate-screen - } else { - error "usage: punk::xmore args where args are run as {*}\$args | more" - } - } - - - #environment path as list - # - #return *appendable* pipeline - i.e no args via <| - proc path_list_pipe {{glob *}} { - if {$::tcl_platform(platform) eq "windows"} { - set sep ";" - } else { - # : ok for linux/bsd ... mac? - set sep ":" - } - set cond [string map [list $glob] {expr {[string length $item] && [string match $item]}}] - #env members such as ''path' not case sensitive on windows - but are on some other platforms (at least FreeBSD) - return [list .= set ::env(PATH) |> .=>2 string trimright $sep |> .=>1 split $sep |> list_filter_cond $cond ] - } - proc path_list {{glob *}} { - set pipe [punk::path_list_pipe $glob] - {*}$pipe - } - proc path {{glob *}} { - set pipe [punk::path_list_pipe $glob] - {*}$pipe |> list_as_lines - } - - #------------------------------------------------------------------- - #sh 'test' equivalent - to be used with exitcode of process - # - - #single evaluation to get exitcode - proc sh_test {args} { - set a1 [lindex $args 0] - if {$a1 in [list -b -c -d -e -f -h -L -s -S -x -w]} { - set a2 [lindex $args 1] - if {![catch { - set attrinfo [file attributes $a2] - } errM]} { - if {[dict exists $attrinfo -vfs] && [dict get $attrinfo -vfs] == 1} { - puts stderr "WARNING: external 'test' being called on vfs path. External command will probably not have access to the vfs. Use 'TEST' for Tcl view of vfs mounted filesystems." - } - } - } - tailcall run test {*}$args - } - - #whether v is an integer from perspective of unix test command. - #can be be bigger than a tcl int or wide ie bignum - but must be whole number - #test doesn't handle 1.0 - so we shouldn't auto-convert - proc is_sh_test_integer {v} { - if {[string first . $v] >=0 || [string first e $v] >= 0} { - return false - } - #if it is double but not sci notation and has no dots - then we can treat as a large integer for 'test' - if {[string is double -strict $v]} { - return true - } else { - return false - } - } - #can use double-evaluation to get true/false - #faster tcl equivalents where possible to accuratley provide, and fallthrough to sh for compatibility of unimplemented - #The problem with fallthrough is that sh/bash etc have a different view of existant files - #e.g unix files such as /dev/null vs windows devices such as CON,PRN - #e.g COM1 is mapped as /dev/ttyS1 in wsl (?) - #Note also - tcl can have vfs mounted file which will appear as a directory to Tcl - but a file to external commands! - #We will stick with the Tcl view of the file system. - #User can use their own direct calls to external utils if - #Note we can't support $? directly in Tcl - script would have to test ${?} or use [set ?] - proc sh_TEST {args} { - upvar ? lasterr - set lasterr 0 - set a1 [lindex $args 0] - set a2 [lindex $args 1] - set a3 [lindex $args 2] - set fileops [list -b -c -d -e -f -h -L -s -S -x -w] - if {[llength $args] == 1} { - #equivalent of -n STRING - set boolresult [expr {[string length $a1] != 0}] - } elseif {[llength $args] == 2} { - if {$a1 in $fileops} { - if {$::tcl_platform(platform) eq "windows"} { - #e.g trailing dot or trailing space - if {[punk::winpath::illegalname_test $a2]} { - #protect with \\?\ to stop windows api from parsing - #will do nothing if already prefixed with \\?\ - - set a2 [punk::winpath::illegalname_fix $a2] - } - } - } - switch -- $a1 { - -b { - #dubious utility on FreeBSD, windows? - #FreeBSD has dropped support for block devices - stating 'No serious applications rely on block devices' - #Linux apparently uses them though - if{[file exists $a2]} { - set boolresult [expr {[file type $a2] eq "blockSpecial"}] - } else { - set boolresult false - } - } - -c { - #e.g on windows CON,NUL - if {[file exists $a2]} { - set boolresult [expr {[file type $a2] eq "characterSpecial"}] - } else { - set boolresult false - } - } - -d { - set boolresult [file isdirectory $a2] - } - -e { - set boolresult [file exists $a2] - } - -f { - #e.g on windows CON,NUL - if {[file exists $a2]} { - set boolresult [expr {[file type $a2] eq "file"}] - } else { - set boolresult false - } - } - -h - - -L { - set boolresult [expr {[file type $a2] eq "link"}] - } - -s { - set boolresult [expr {[file exists $a2] && ([file size $a2] > 0 )}] - } - -S { - if {[file exists $a2]} { - set boolresult [expr {[file type $a2] eq "socket"}] - } else { - set boolresult false - } - } - -x { - set boolresult [expr {[file exists $a2] && [file executable $a2]}] - } - -w { - set boolresult [expr {[file exists $a2] && [file writable $a2]}] - } - -z { - set boolresult [expr {[string length $a2] == 0}] - } - -n { - set boolresult [expr {[string length $a2] != 0}] - } - default { - puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" - #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] - set callinfo [runx test {*}$args] - set errinfo [dict get $callinfo stderr] - set exitcode [dict get $callinfo exitcode] - if {[string length $errinfo]} { - puts stderr "sh_TEST error in external call to 'test $args': $errinfo" - set lasterr $exitcode - } - if {$exitcode == 0} { - set boolresult true - } else { - set boolresult false - } - } - } - } elseif {[llength $args] == 3} { - switch -- $a2 { - "=" { - #test does string comparisons - set boolresult [string equal $a1 $a3] - } - "!=" { - #string comparison - set boolresult [expr {$a1 ne $a3}] - } - "-eq" { - #test expects a possibly-large integer-like thing - #shell scripts will - if {![is_sh_test_integer $a1]} { - puts stderr "sh_TEST: invalid integer '$a1'" - set lasterr 2 - return false - } - if {![is_sh_test_integer $a3]} { - puts stderr "sh_TEST: invalid integer '$a3'" - set lasterr 2 - return false - } - set boolresult [expr {$a1 == $a3}] - } - "-ge" { - if {![is_sh_test_integer $a1]} { - puts stderr "sh_TEST: invalid integer '$a1'" - set lasterr 2 - return false - } - if {![is_sh_test_integer $a3]} { - puts stderr "sh_TEST: invalid integer '$a3'" - set lasterr 2 - return false - } - set boolresult [expr {$a1 >= $a3}] - } - "-gt" { - if {![is_sh_test_integer $a1]} { - puts stderr "sh_TEST: invalid integer '$a1'" - set lasterr 2 - return false - } - if {![is_sh_test_integer $a3]} { - puts stderr "sh_TEST: invalid integer '$a3'" - set lasterr 2 - return false - } - set boolresult [expr {$a1 > $a3}] - } - "-le" { - if {![is_sh_test_integer $a1]} { - puts stderr "sh_TEST: invalid integer '$a1'" - set lasterr 2 - return false - } - if {![is_sh_test_integer $a3]} { - puts stderr "sh_TEST: invalid integer '$a3'" - set lasterr 2 - return false - } - set boolresult [expr {$a1 <= $a3}] - } - "-lt" { - if {![is_sh_test_integer $a1]} { - puts stderr "sh_TEST: invalid integer '$a1'" - set lasterr 2 - return false - } - if {![is_sh_test_integer $a3]} { - puts stderr "sh_TEST: invalid integer '$a3'" - set lasterr 2 - return false - } - set boolresult [expr {$a1 < $a3}] - } - "-ne" { - if {![is_sh_test_integer $a1]} { - puts stderr "sh_TEST: invalid integer '$a1'" - set lasterr 2 - return false - } - if {![is_sh_test_integer $a3]} { - puts stderr "sh_TEST: invalid integer '$a3'" - set lasterr 2 - return false - } - set boolresult [expr {$a1 != $a3}] - } - default { - puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" - #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] - set callinfo [runx test {*}$args] - set errinfo [dict get $callinfo stderr] - set exitcode [dict get $callinfo exitcode] - if {[string length $errinfo]} { - puts stderr "sh_TEST error in external call to 'test $args': $errinfo" - set lasterr $exitcode - } - if {$exitcode == 0} { - set boolresult true - } else { - set boolresult false - } - - } - } - } else { - puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" - #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] - set callinfo [runx test {*}$args] - set errinfo [dict get $callinfo stderr] - set exitcode [dict get $callinfo exitcode] - if {[string length $errinfo]} { - puts stderr "sh_TEST error in external call to 'test $args': $errinfo" - set lasterr $exitcode - } - if {$exitcode == 0} { - set boolresult true - } else { - set boolresult false - } - } - - #normalize 1,0 etc to true,false - #we want to make it obvious we are not just reporting exitcode 0 for example - which represents true in tcl. - if {$boolresult} { - return true - } else { - if {$lasterr == 0} { - set lasterr 1 - } - return false - } - - - } - proc sh_echo {args} { - tailcall run echo {*}$args - } - proc sh_ECHO {args} { - #execute the result of the run command - which is something like: 'exitcode n' - to get true/false - tailcall apply {arglist {uplevel #0 [run echo {*}$arglist]} ::} $args - } - - - #sh style true/false for process exitcode. 0 is true - everything else false - proc exitcode {args} { - set c [lindex $args 0] - if {[string is integer -strict $c]} { - #return [expr {$c == 0}] - #return true/false to make it clearer we are outputting tcl-boolean inverse mapping from the shell style 0=true - if {$c == 0} { - return true - } else { - return false - } - } else { - return false - } - } - #------------------------------------------------------------------- - - namespace export help aliases alias exitcode % pipedata pipecase pipeline pipematch pipeswitch pipeswitchc pipecase linelist linesort inspect list_as_lines val treemore - - #namespace ensemble create - - - - - #tilde - #These aliases work fine for interactive use - but the result is always a string int-rep - #interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) - #interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} - proc ~ {args} { - set hdir [punk::objclone $::env(HOME)] - file pathtype $hdir - set d $hdir - #use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions - foreach a $args { - set d [file join $d $a] - } - file pathtype $d - return [punk::objclone $d] - } - interp alias {} ~ {} punk::~ - - - #maint - punk::args has similar - #this is largely obsolete - uses dict for argspecs (defaults) instead of textblock as in punk::args - #textblock has more flexibility in some ways - but not as easy to manipulate especially with regards to substitutions - #todo - consider a simple wrapper for punk::args to allow calling with dict of just name and default? - #JMN - #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values - #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. - #only supports -flag val pairs, not solo options - #If an option is supplied multiple times - only the last value is used. - #TODO - remove - proc get_leading_opts_and_values {defaults rawargs args} { - if {[llength $defaults] %2 != 0} { - error "get_leading_opts_and_values expected first argument 'defaults' to be a dictionary" - } - dict for {k v} $defaults { - if {![string match -* $k]} { - error "get_leading_opts_and_values problem with supplied defaults. Expect each key to begin with a dash. Got key '$k'" - } - } - #puts "--> [info frame -2] <--" - set cmdinfo [dict get [info frame -2] cmd] - #we can't treat cmdinfo as a list - it may be something like {command {*}$args} in which case lindex $cmdinfo 0 won't work - #hopefully first word is a plain proc name if this function was called in the normal manner - directly from a proc - #we will break at first space and assume the lhs of that will give enough info to be reasonable - (alternatively we could use entire cmdinfo - but it might be big and ugly) - set caller [regexp -inline {\S+} $cmdinfo] - - #if called from commandline or some other contexts such as outside of a proc in a namespace - caller may just be "namespace" - if {$caller eq "namespace"} { - set caller "get_leading_opts_and_values called from namespace" - } - - # ------------------------------ - if {$caller ne "get_leading_opts_and_values"} { - #check our own args - lassign [get_leading_opts_and_values {-anyopts 0 -minvalues 0 -maxvalues -1} $args] _o ownopts _v ownvalues - if {[llength $ownvalues] > 0} { - error "get_leading_opts_and_values expected: a dictionary of defaults, a list of args and at most two option pairs -minvalues and -maxvalues - got extra arguments: '$ownvalues'" - } - set opt_minvalues [dict get $ownopts -minvalues] - set opt_maxvalues [dict get $ownopts -maxvalues] - set opt_anyopts [dict get $ownopts -anyopts] - } else { - #don't check our own args if we called ourself - set opt_minvalues 0 - set opt_maxvalues 0 - set opt_anyopts 0 - } - # ------------------------------ - - if {[set eopts [lsearch $rawargs "--"]] >= 0} { - set values [lrange $rawargs $eopts+1 end] - set arglist [lrange $rawargs 0 $eopts-1] - } else { - if {[lsearch $rawargs -*] >= 0} { - #to support option values with leading dash e.g -offset -1 , we can't just take the last flagindex - set i 0 - foreach {k v} $rawargs { - if {![string match -* $k]} { - break - } - if {$i+1 >= [llength $rawargs]} { - #no value for last flag - error "bad options for $caller. No value supplied for last option $k" - } - incr i 2 - } - set arglist [lrange $rawargs 0 $i-1] - set values [lrange $rawargs $i end] - } else { - set values $rawargs ;#no -flags detected - set arglist [list] - } - } - if {$opt_maxvalues == -1} { - #only check min - if {[llength $values] < $opt_minvalues} { - error "bad number of trailing values for $caller. Got [llength $values] values. Expected at least $opt_minvalues" - } - } else { - if {[llength $values] < $opt_minvalues || [llength $values] > $opt_maxvalues} { - if {$opt_minvalues == $opt_maxvalues} { - error "bad number of trailing values for $caller. Got [llength $values] values. Expected exactly $opt_minvalues" - } else { - error "bad number of trailing values for $caller. Got [llength $values] values. Expected between $opt_minvalues and $opt_maxvalues inclusive" - } - } - } - - if {!$opt_anyopts} { - set checked_args [dict create] - for {set i 0} {$i < [llength $arglist]} {incr i} { - #allow this to error out with message indicating expected flags - dict set checked_args [tcl::prefix match -message "options for $caller. Unexpected option" [dict keys $defaults] [lindex $arglist $i]] [lindex $arglist $i+1] - incr i ;#skip val - } - } else { - set checked_args $arglist - } - set opts [dict merge $defaults $checked_args] - - #maintain order of opts $opts values $values as caller may use lassign. - return [dict create opts $opts values $values] - } - - - - - - - - - - #-------------------------------------------------- - #some haskell-like operations - #group equivalent - #http://zvon.org/other/haskell/Outputlist/group_f.html - #as we can't really distinguish a single element list from a string we will use 2 functions - proc group_list1 {lst} { - set out [list] - set prev [lindex $lst 0] - set g [list] - foreach i $lst { - if {$i eq $prev} { - lappend g $i - } else { - lappend out $g - set g [list $i] - } - set prev $i - } - lappend out $g - return $out - } - proc group_list {lst} { - set out [list] - set next [lindex $lst 1] - set tail [lassign $lst x] - set g [list $x] - set y [lindex $tail 0] - set last_condresult [expr {$x}] - set n 1 ;#start at one instead of zero for lookahead - foreach x $tail { - set y [lindex $tail $n] - set condresult [expr {$x}] - if {$condresult eq $last_condresult} { - lappend g $x - } else { - lappend out $g - set g [list $x] - set last_condresult $condresult - } - incr n - } - lappend out $g - return $out - } - - #NOT attempting to match haskell other than in overall concept. - # - #magic var-names are a bit of a code-smell. But submitting only an expr argument is more Tcl-like than requiring an 'apply' specification. - #Haskell seems to take an entire lambda so varnames can be user-specified - but the 'magic' there is in it's choice of submitting 2 elements at a time - #We could do similar .. but we'll focus on comprehensibility for the basic cases - especially as begginning and end of list issues could be confusing. - # - #vars: index prev, prev0, prev1, item, next, next0, next1,nextr, cond - #(nextr is a bit obscure - but basically means next-repeat ie if no next - use same value. just once though.) - #group by cond result or first 3 wordlike parts of error - #e.g group_list_by {[lindex $item 0]} {{a 1} {a 2} {b 1}} - proc group_list_by {cond lst} { - set out [list] - set prev [list] - set next [lindex $lst 1] - set tail [lassign $lst item] - set g [list $item] - set next [lindex $tail 0] - if {$prev eq ""} { - set prev0 0 - set prev1 1 - set prevr $item - } else { - set prev0 $prev - set prev1 $prev - set prevr $prev - } - if {$next eq ""} { - set next0 0 - set next1 1 - set nextr $item - } else { - set next0 $next - set next1 $next - set nextr $next - } - set last_condresult [apply {{index cond prev prev0 prev1 prevr item next next0 next1 nextr} { - if {[catch {expr $cond} r]} { - puts stderr "index: 0 ERROR $r" - set wordlike_parts [regexp -inline -all {\S+} $r] - set r [list ERROR {*}[lrange $wordlike_parts 0 2]] - } - set r - } - } 0 $cond $prev $prev0 $prev1 $prevr $item $next $next0 $next1 $nextr] - set n 1 ;#start at one instead of zero for lookahead - #note - n also happens to matchi zero-based index of original list - set prev $item - foreach item $tail { - set next [lindex $tail $n] - if {$prev eq ""} { - set prev0 0 - set prev1 1 - set prevr $item - } else { - set prev0 $prev - set prev1 $prev - set prevr $prev - } - if {$next eq ""} { - set next0 0 - set next1 1 - set nextr $item - } else { - set next0 $next - set next1 $next - set nextr $next - } - set condresult [apply {{index cond prev prev0 prev1 prevr item next next0 next1 nextr} { - if {[catch {expr $cond} r]} { - puts stderr "index: $index ERROR $r" - set wordlike_parts [regexp -inline -all {\S+} $r] - set r [list ERROR {*}[lrange $wordlike_parts 0 2]] - } - set r - } - } $n $cond $prev $prev0 $prev1 $prevr $item $next $next0 $next1 $nextr] - if {$condresult eq $last_condresult} { - lappend g $item - } else { - lappend out $g - set g [list $item] - set last_condresult $condresult - } - incr n - set prev $item - } - lappend out $g - return $out - } - - #group_numlist ? preserve representation of numbers rather than use string comparison? - - - # - group_string - #.= punk::group_string "aabcccdefff" - # aa b ccc d e fff - proc group_string {str} { - lmap v [group_list [split $str ""]] {string cat {*}$v} - } - - #lists may be of unequal lengths - proc transpose_lists {list_rows} { - set res {} - #set widest [pipedata $list_rows {lmap v $data {llength $v}} {tcl::mathfunc::max {*}$data}] - set widest [tcl::mathfunc::max {*}[lmap v $list_rows {llength $v}]] - for {set j 0} {$j < $widest} {incr j} { - set newrow {} - foreach oldrow $list_rows { - if {$j >= [llength $oldrow]} { - #continue - lappend newrow "" - } else { - lappend newrow [lindex $oldrow $j] - } - } - lappend res $newrow - } - return $res - } - proc transpose_equal_lists {list_rows} { - set columns [list] - set rowidx -1 - foreach l $list_rows { - set colidx -1 - incr rowidx - foreach val $l { - incr colidx - lset columns $colidx $rowidx $val - } - } - return $columns - } - proc transpose_strings {list_of_strings} { - set charlists [lmap v $list_of_strings {split $v ""}] - set tchars [transpose_lists $charlists] - lmap v $tchars {string cat {*}$v} - } - - package require struct::matrix - #transpose a serialized matrix using the matrix command - #Note that we can have missing row values below and to right - #e.g - #a - #a b - #a - proc transpose_matrix {matrix_rows} { - set mcmd [struct::matrix] - #serialization format: numcols numrows rowlist - set widest [tcl::mathfunc::max {*}[lmap v $matrix_rows {llength $v}]] - $mcmd deserialize [list [llength $matrix_rows] $widest $matrix_rows] - $mcmd transpose - set result [lindex [$mcmd serialize] 2] ;#strip off dimensions - $mcmd destroy - return $result - } - - set objname [namespace current]::matrixchain - if {$objname ni [info commands $objname]} { - oo::class create matrixchain { - variable mcmd - constructor {matrixcommand} { - puts "wrapping $matrixcommand with [self]" - set mcmd $matrixcommand - } - destructor { - puts "matrixchain destructor called for [self] (wrapping $mcmd)" - $mcmd destroy - } - method unknown {args} { - if {[llength $args]} { - switch -- [lindex $args 0] { - add - delete - insert - transpose - sort - set - swap { - $mcmd {*}$args - return [self] ;#result is the wrapper object for further chaining in pipelines - } - default { - tailcall $mcmd {*}$args - } - } - } else { - #will error.. but we should pass that on - tailcall $mcmd - } - } - } - } - - #review - #how do we stop matrix pipelines from leaving commands around? i.e how do we call destroy on the matrixchain wrapper if not explicitly? - #Perhaps will be solved by: Tip 550: Garbage collection for TclOO - #Theoretically this should allow tidy up of objects created within the pipeline automatically - #If the object name is placed in the pipeline variable dict then it should survive across segment apply scripts and only go out of scope at the end. - proc matrix_command_from_rows {matrix_rows} { - set mcmd [struct::matrix] - set widest [tcl::mathfunc::max {*}[lmap v $matrix_rows {llength $v}]] - $mcmd deserialize [list [llength $matrix_rows] $widest $matrix_rows] - #return $mcmd - set wrapper [punk::matrixchain new $mcmd] - } - - #-------------------------------------------------- - - proc list_filter_cond {itemcond listval} { - set filtered_list [list] - set binding {} - if {[info level] == 1} { - #up 1 is global - set get_vars [list ::info vars] - } else { - set get_vars [list ::info locals] - } - set vars [uplevel 1 {*}$get_vars] - set posn [lsearch $vars item] - set vars [lreplace $vars $posn $posn] - foreach v $vars { - upvar 1 $v var - if {(![array exists var]) && [info exists var]} { - lappend binding [list $v $var] ;#values captured as defaults for apply args. - } - } - #lappend binding [list item $args] - - #puts stderr "binding: [join $binding \n]" - #apply [list $binding $pipescript [uplevel 1 ::namespace current]] - foreach item $listval { - set bindlist [list {*}$binding [list item $item]] - if {[apply [list $bindlist $itemcond [uplevel 1 ::namespace current]] ]} { - lappend filtered_list $item - } - } - return $filtered_list - } - - - proc ls {args} { - if {![llength $args]} { - set args [list [pwd]] - } - if {[llength $args] ==1} { - return [glob -nocomplain -tails -dir [lindex $args 0] *] - } else { - set result [dict create] - foreach a $args { - set k [file normalize $a] - set contents [glob -nocomplain -tails -dir $a *] - dict set result $k $contents - } - return $result - } - } - - - - #linelistraw is essentially split $text \n so is only really of use for pipelines, where the argument order is more convenient - #like linelist - but keeps leading and trailing empty lines - #single \n produces {} {} - #the result can be joined to reform the arg if a single arg supplied - # - proc linelistraw {args} { - set linelist [list] - foreach {a} $args { - set nlsplit [split $a \n] - lappend linelist {*}$nlsplit - } - #return [split $text \n] - return $linelist - } - proc linelist1 {args} { - set linelist [list] - foreach {a} $args { - set nlsplit [split $a \n] - set start 0 - set end "end" - - if {[lindex $nlsplit 0] eq ""} { - set start 1 - } - if {[lindex $nlsplit end] eq ""} { - set end "end-1" - } - set alist [lrange $nlsplit $start $end] - lappend linelist {*}$alist - } - return $linelist - } - - namespace eval argdoc { - set DYN_ANTIGLOB_PATHS {${[punk::args::resolved_def -types opts ::punk::path::treefilenames -antiglob_paths]}} - punk::args::define { - @dynamic - @id -id ::punk::LOC - @cmd -name punk::LOC\ - -summary\ - "Lines Of Code counter"\ - -help\ - "LOC - lines of code. - An implementation of a notoriously controversial metric. - Returns a dict or dictionary-display containing various - counts such as: - 'loc' - total lines of code. - 'purepunctuationlines' - lines consisting soley of punctuation. - 'filecount' - number of files examined." - @opts - -return -default showdict -choices {dict showdict} - -dir -default "\uFFFF" - -exclude_dupfiles -default 1 -type boolean - ${$DYN_ANTIGLOB_PATHS} - -antiglob_files -default "" -type list -help\ - "Exclude if file tail matches any of these patterns" - -exclude_punctlines -default 1 -type boolean - -show_largest -default 0 -type integer -help\ - "Report the top largest linecount files. - The value represents the number of files - to report on." - } " - #we could map away whitespace and use string is punct - but not as flexible? review - -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } - " { - @values - fileglob -type string -default * -optional 1 -multiple 1 -help\ - "glob patterns to match against the filename portion (last segment) of each - file path. e.g *.tcl *.tm" - } - } - #An implementation of a notoriously controversial metric. - proc LOC {args} { - set argd [punk::args::parse $args withid ::punk::LOC] - lassign [dict values $argd] leaders opts values received - set searchspecs [dict get $values fileglob] - - # -- --- --- --- --- --- - set opt_return [dict get $opts -return] - set opt_dir [dict get $opts -dir] - if {$opt_dir eq "\uFFFF"} { - set opt_dir [pwd] ;#pwd can take over a ms on windows in a not terribly deep path even with SSDs - so as a general rule we don't use it in the original defaults list - } - # -- --- --- --- --- --- - set opt_exclude_dupfiles [dict get $opts -exclude_dupfiles] - set opt_exclude_punctlines [dict get $opts -exclude_punctlines] ;#exclude lines that consist purely of whitespace and the chars in -punctchars - set opt_punctchars [dict get $opts -punctchars] - set opt_largest [dict get $opts -show_largest] - set opt_antiglob_paths [dict get $opts -antiglob_paths] - set opt_antiglob_files [dict get $opts -antiglob_files] - # -- --- --- --- --- --- - - - set filepaths [punk::path::treefilenames -dir $opt_dir -antiglob_paths $opt_antiglob_paths -antiglob_files $opt_antiglob_files {*}$searchspecs] - set loc 0 - set dupfileloc 0 - set seentails [dict create] - set seencksums [dict create] ;#key is cksum value is list of paths - set largestloc [dict create] - set dupfilecount 0 - set extensions [list] - set purepunctlines 0 - set dupinfo [dict create] - set has_hashfunc [expr {![catch {package require sha1}]}] - set notes "" - if {$has_hashfunc} { - set dupfilemech sha1 - if {$opt_exclude_punctlines} { - append notes "checksums are on content stripped of whitespace lines,trailing whitespace, and pure punct lines. Does not indicate file contents equal.\n" - } else { - append notes "checksums are on content stripped of whitespace lines and trailing whitespace. Does not indicate file contents equal.\n" - } - } else { - set dupfilemech filetail - append notes "dupfilemech filetail because sha1 not loadable\n" - } - foreach fpath $filepaths { - set isdupfile 0 - set floc 0 - set fpurepunctlines 0 - set ext [file extension $fpath] - if {$ext ni $extensions} { - lappend extensions $ext - } - if {[catch {fcat $fpath} contents]} { - puts stderr "Error processing $fpath\n $contents" - continue - } - set lines [linelist -line {trimright} -block {trimall} $contents] - if {!$opt_exclude_punctlines} { - set floc [llength $lines] - set comparedlines $lines - } else { - set mapawaypunctuation [list] - foreach p $opt_punctchars empty {} { - lappend mapawaypunctuation $p $empty - } - set comparedlines [list] - foreach ln $lines { - if {[string length [string trim [string map $mapawaypunctuation $ln]]] > 0} { - incr floc - lappend comparedlines $ln - } else { - incr fpurepunctlines - } - } - } - if {$opt_largest > 0} { - dict set largestloc $fpath $floc - } - if {$has_hashfunc} { - set cksum [sha1::sha1 [encoding convertto utf-8 [join $comparedlines \n]]] - if {[dict exists $seencksums $cksum]} { - set isdupfile 1 - incr dupfilecount - incr dupfileloc $floc - dict lappend seencksums $cksum $fpath - } else { - dict set seencksums $cksum [list $fpath] - } - } else { - if {[dict exists $seentails [file tail $fpath]]} { - set isdupfile 1 - incr dupfilecount - incr dupfileloc $floc - } - } - if {!$isdupfile || ($isdupfile && !$opt_exclude_dupfiles)} { - incr loc $floc - incr purepunctlines $fpurepunctlines - } - - dict lappend seentails [file tail $fpath] $fpath - #lappend seentails [file tail $fpath] - } - if {$has_hashfunc} { - dict for {cksum paths} $seencksums { - if {[llength $paths] > 1} { - dict set dupinfo checksums $cksum $paths - } - } - } - dict for {tail paths} $seentails { - if {[llength $paths] > 1} { - dict set dupinfo sametail $tail $paths - } - } - - if {$opt_exclude_punctlines} { - set result [dict create\ - loc $loc\ - filecount [llength $filepaths]\ - dupfiles $dupfilecount\ - dupfilemech $dupfilemech\ - dupfileloc $dupfileloc\ - dupinfo $dupinfo\ - extensions $extensions\ - purepunctuationlines $purepunctlines\ - notes $notes\ - ] - } else { - set result [dict create\ - loc $loc\ - filecount [llength $filepaths]\ - dupfiles $dupfilecount\ - dupfilemech $dupfilemech\ - dupfileloc $dupfileloc\ - dupinfo $dupinfo\ - extensions $extensions\ - notes $notes\ - ] - } - if {$opt_largest > 0} { - set largest_n [dict create] - set sorted [lsort -stride 2 -index 1 -decreasing -integer $largestloc] - set kidx 0 - for {set i 0} {$i < $opt_largest} {incr i} { - if {$kidx+1 > [llength $sorted]} {break} - dict set largest_n [lindex $sorted $kidx] [lindex $sorted $kidx+1] - incr kidx 2 - } - dict set result largest $largest_n - } - if {$opt_return eq "showdict"} { - return [punk::lib::showdict $result @@dupinfo/*/* !@@dupinfo] - } - return $result - } - - ##dict of lists? - #a - # 1 - # 2 - #b - # 3 - # 4 - # "" - # etc - # d - # D - # "ok then" - - - ##dict of dicts - #a - # x - # 1 - # y - # 2 - #b - # x - # 11 - - ##dict of mixed - #list - # a - # b - # c - #dict - # a - # aa - # b - # bb - #val - # x - #list - # a - # b - - # each line has 1 key or value OR part of 1 key or value. ie <=1 key/val per line! - ##multiline - #key - # "multi - # line value" - # - - #-------------------------------- - #a - # 1 - # 2 - - #vs - - #a - # 1 - # 2 - - #dict of list-len 2 is equiv to dict of dict with one keyval pair - #-------------------------------- - - - - #!!!todo fix - linedict is unfinished and non-functioning - #linedict based on indents - proc linedict {args} { - puts stderr "linedict is experimental and incomplete" - set data [lindex $args 0] - set opts [lrange $args 1 end] ;#todo - set nlsplit [split $data \n] - set rootindent -1 - set stepindent -1 - - - #first do a partial loop through lines and work out the rootindent and stepindent. - #we could do this in the main loop - but we do it here to remove a small bit of logic from the main loop. - #review - if we ever move to streaming a linedict - we'll need to re-arrange to validating indents as we go anyway. - set linenum 0 - set firstkey_line "N/A" - set firstkey_linenum -1 - set firststep_line "N/A" - set firststep_linenum -1 - set indents_seen [dict create] - foreach ln $nlsplit { - incr linenum - if {![string length [string trim $ln]]} { - continue - } - - #todo - use info complete to accept keys/values with newlines - regexp {(\s*)(.*)} $ln _ space linedata - if {[catch {lindex $linedata 0}]} { - error "bad line value '$linedata' - each line must be a valid Tcl list of length 1. Use quotes or curly braces as necessary" - } - if {[llength $linedata] > 1} { - error "bad line value '$linedata' - each line must be a valid Tcl list of length 1. Use quotes or curly braces as necessary" - } - #puts stderr "--linenum:[format %-3s $linenum] line:[format "%-20s" $ln] [format %-4s [string length $space]] $linedata" - set this_indent [string length $space] - if {[dict exists $indents_seen $this_indent]} { - continue - } - if {$rootindent < 0} { - set firstkey_line $ln - set firstkey_linenum $linenum - set rootindent $this_indent - dict set indents_seen $this_indent 1 - } elseif {$stepindent < 0} { - if {$this_indent > $rootindent} { - set firststep_line $ln - set firststep_linenum $linenum - set stepindent [expr {$this_indent - $rootindent}] - dict set indents_seen $this_indent 1 - } elseif {$this_indent < $rootindent} { - error "bad root indentation ($this_indent) at line: $linenum. Smallest indent was set on linenumber: $firstkey_linenum by first key line: $firstkey_line" - } - #if equal - it's just another root key - } else { - #validate all others - if {$this_indent < $rootindent} { - error "bad root indentation ($this_indent) at line: $linenum. Smallest indent was set on linenumber: $firstkey_linenum by first key line: $firstkey_line" - } - if {($this_indent - $rootindent) % $stepindent != 0} { - error "bad indentation ($this_indent) at linenum: $linenum line:'$ln'. this_indent - rootindent ($this_indent - $rootindent == [expr {$this_indent - $rootindent}]) is not a multiple of the first key indent $stepindent seen on linenumber: $firststep_linenum value:'$firststep_line'" - } else { - dict set indents_seen $this_indent 1 - } - } - } - - - #set wordlike_parts [regexp -inline -all {\S+} $lastitem] - set d [dict create] - set keys [list] - set linenum 0 ;#line-numbers 1 based - foreach ln $nlsplit { - incr linenum - if {![string length [string trim $ln]]} { - incr linenum - continue - } - regexp {(\s*)(.*)} $ln _ space linedata - puts stderr ">>linenum:[format %-3s $linenum] line:[format "%-20s " $ln] [format %-4s [string length $space]] $linedata" - set linedata [lindex $linedata 0] - set this_indent [string length $space] - - - if {$this_indent == $rootindent} { - #is rootkey - dict set d $linedata {} - set keys [list $linedata] - } else { - set ispan [expr {$this_indent - $rootindent}] - set numsteps [expr {$ispan / $stepindent}] - #assert - since validated in initial loop - numsteps is always >= 1 - set keydepth [llength $keys] - if {$numsteps > $keydepth + 1} { - #too deep - not tested for in initial loop. ? todo - convert to leading spaces in key/val? - error "bad indentation ($this_indent) at linenum: $linenum line:'$ln'. (too deep) - review" - } - if {$numsteps > ($keydepth - 1)} { - #assert - from above test - must be 1 or 2 deeper - set parentkey [lindex $keys end] - set oldval [dict get $d {*}$parentkey] - if {$numsteps - ($keydepth -1) == 1} { - #1 deeper - if {$oldval ne {}} { - lappend keys [list {*}$parentkey $linedata] - dict unset d {*}$parentkey - #dict set d {*}$parentkey $oldval $linedata - dict set d {*}$parentkey $oldval {} ;#convert to key? - dict set d {*}$parentkey $linedata {} - } else { - dict set d {*}$parentkey $linedata - } - } else { - #2 deeper - only ok if there is an existing val - if {$oldval eq {}} { - error "bad indentation ($this_indent) at linenum: $linenum line:'$ln'. (too deep) - review" - } - puts ">>> 2deep d:'$d' oldval:$oldval linedata:$linedata parentkey:$parentkey" - dict unset d {*}$parentkey - dict set d {*}$parentkey $oldval $linedata - lappend keys [list {*}$parentkey $oldval] - } - } elseif {$numsteps < ($keydepth - 1)} { - set diff [expr {$keydepth - 1 - $numsteps}] - set keys [lrange $keys 0 end-$diff] - #now treat as same level - set parentkey [lindex $keys end-1] - lset keys end end $linedata - dict set d {*}$parentkey $linedata {} - } else { - #same level - set parentkey [lindex $keys end-1] - lset keys end end $linedata - dict set d {*}$parentkey $linedata {} - } - } - #puts ">>keys:$keys" - } - return $d - } - proc dictline {d {indent 2}} { - puts stderr "unimplemented" - set lines [list] - - return $lines - } - - - proc ooinspect {obj} { - set obj [uplevel 1 [list namespace which -command $obj]] - set isa [lmap type {object class metaclass} { - if {![info object isa $type $obj]} continue - set type - }] - foreach tp $isa { - switch -- $tp { - class { - lappend info {class superclasses} {class mixins} {class filters} - lappend info {class methods} {class methods} - lappend info {class variables} {class variables} - } - object { - lappend info {object class} {object mixins} {object filters} - lappend info {object methods} {object methods} - lappend info {object variables} {object variables} - lappend info {object namespace} {object vars} ;#{object commands} - } - } - } - - set result [dict create isa $isa] - foreach args $info { - dict set result $args [info {*}$args $obj] - foreach opt {-private -all} { - catch { - dict set result [list {*}$args $opt] [info {*}$args $obj $opt] - } - } - } - dict filter $result value {?*} - } - - punk::args::define { - @id -id ::punk::inspect - @cmd -name punk::inspect -help\ - "Function to display values - used pimarily in a punk pipeline. - The raw value arguments (not options) are always returned to pass - forward in the pipeline. - (pipeline data inserted at end of each |...> segment is passed as single item unless - inserted with an expanding insertion specifier such as .=>* ) - e.g1: - .= list a b c |v1,/1-end,/0>\\ - .=>* inspect -label i1 -- |>\\ - .=v1> inspect -label i2 -- |>\\ - string toupper - (3) i1: {a b c} {b c} a - (1) i2: a b c - - - A B C - " - -label -type string -default "" -help\ - "An optional label to help distinguish output when multiple - inspect statements are in a pipeline. This appears after the - bracketed count indicating number of values supplied. - e.g (2) MYLABEL: val1 val2 - The label can include ANSI codes. - e.g - inspect -label [a+ red]mylabel -- val1 val2 val3 - " - -limit -type int -default 20 -help\ - "When multiple values are passed to inspect - limit the number - of elements displayed in -channel output. - When truncation has occured an elipsis indication (...) will be appended. - e.g - .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ - (11) 20 23 26 29... - - - 385 - - For no limit - use -limit -1 - " - -channel -type string -default stderr -help\ - "An existing open channel to write to. If value is any of nul, null, /dev/nul - the channel output is disabled. This effectively disables inspect as the args - are simply passed through in the return to continue the pipeline. - " - -showcount -type boolean -default 1 -help\ - "Display a leading indicator in brackets showing the number of arg values present." - -ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels { - 0 "Strip ANSI codes from display - of values. The disply output will - still be colourised if -ansibase has - not been set to empty string or - [a+ normal]. The stderr or stdout - channels may also have an ansi colour. - (see 'colour off' or punk::config)" - 1 "Leave value as is" - 2 "Display the ANSI codes and - other control characters inline - with replacement indicators. - e.g esc, newline, space, tab" - VIEW "Alias for 2" - 3 "Display as per 2 but with - colourised ANSI replacement codes." - VIEWCODES "Alias for 3" - 4 "Display ANSI and control - chars in default colour, but - apply the contained ansi to - the text portions so they display - as they would for -ansi 1" - VIEWSTYLE "Alias for 4" - } - -ansibase -type ansistring -default {${[a+ brightgreen]}} -help\ - "Base ansi code(s) that will apply to output written to the chosen -channel. - If there are ansi resets in the displayed values - output will revert to this base. - Does not affect return value." - -- -type none -help\ - "End of options marker. - It is advisable to use this, as data in a pipeline may often begin with -" - - @values -min 0 -max -1 - arg -type string -optional 1 -multiple 1 -help\ - "value to display" - } - #pipeline inspect - #e.g - #= {a z c} |> inspect -label input_dict |> lsort |> {inspect $data} - proc inspect {args} { - set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1 -ansibase [a+ brightgreen]] - set flags [list] - set endoptsposn [lsearch $args --] ;#first -- if data expected to contain --, then should always be called with --. e.g inspect -- - if {$endoptsposn >= 0} { - set flags [lrange $args 0 $endoptsposn-1] - set pipeargs [lrange $args $endoptsposn+1 end] - } else { - #no explicit end of opts marker - #last trailing elements of args after taking *known* -tag v pairs is the value to inspect - for {set i 0} {$i < [llength $args]} {incr i} { - set k [lindex $args $i] - if {$k in [dict keys $defaults]} { - lappend flags {*}[lrange $args $i $i+1] - incr i - } else { - #first unrecognised option represents end of flags - break - } - } - set pipeargs [lrange $args $i end] - } - foreach {k v} $flags { - if {$k ni [dict keys $defaults]} { - #error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --" - punk::args::get_by_id ::punk::inspect $args - } - } - set opts [dict merge $defaults $flags] - # -- --- --- --- --- - set label [dict get $opts -label] - set channel [dict get $opts -channel] - set showcount [dict get $opts -showcount] - if {[string length $label]} { - set label "${label}: " - } - set limit [dict get $opts -limit] - set opt_ansiraw [dict get $opts -ansi] - set opt_ansi [tcl::prefix::match -error "" [list 0 1 2 3 4 view viewcodes viewstyle] [string tolower $opt_ansiraw]] - switch -- [string tolower $opt_ansi] { - 0 - 1 - 2 - 3 - 4 {} - view {set opt_ansi 2} - viewcodes {set opt_ansi 3} - viewstyle {set opt_ansi 4} - default { - error "inspect -ansi 0|1|2|view|3|viewcodes|4|viewstyle - received -ansi $opt_ansiraw" - } - } - # -- --- --- --- --- - - set more "" - if {[llength $pipeargs] == 1} { - #usual case is data as a single element - set val [lindex $pipeargs 0] - set count 1 - } else { - #but the pipeline segment could have an insertion-pattern ending in * - set val $pipeargs - set count [llength $pipeargs] - } - switch -- [string tolower $channel] { - nul - null - /dev/null { - return $val - } - } - set displayval $val ;#default - may be overridden based on -limit - - if {$count > 1} { - #val is a list - set llen [llength $val] - if {$limit > 0 && ($limit < $llen)} { - set displayval [lrange $val 0 $limit-1] - if {$llen > $limit} { - set more "..." - } - } - } else { - #not a valid tcl list - limit by lines - if {$limit > 0} { - set rawlines [split $val \n] - set llen [llength $rawlines] - set displaylines [lrange $rawlines 0 $limit-1] - set displayval [join $displaylines "\n"] - if {$llen > $limit} { - set more "\n..." - } - } - - } - if {$showcount} { - set displaycount "[a purple bold]($count)[a] " - if {$showcount} { - set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space - set margin [string repeat " " $countspace] - set displayval [string map [list \r "" \n "\n$margin"] $displayval] - } - } else { - set displaycount "" - } - - set ansibase [dict get $opts -ansibase] - if {$ansibase ne ""} { - #-ansibase default is hardcoded into punk::args definition - #run a test using any ansi code to see if colour is still enabled - if {[a+ red] eq ""} { - set ansibase "" ;#colour seems to be disabled - } - } - - switch -- $opt_ansi { - 0 { - set displayval $ansibase[punk::ansi::ansistrip $displayval] - } - 1 { - #val may have ansi - including resets. Pass through ansibase_lines to - if {$ansibase ne ""} { - #set displayval [::textblock::ansibase_lines $displayval $ansibase] - set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] - } - } - 2 { - set displayval $ansibase[ansistring VIEW $displayval] - if {$ansibase ne ""} { - #set displayval [::textblock::ansibase_lines $displayval $ansibase] - set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] - } - } - 3 { - set displayval $ansibase[ansistring VIEWCODE $displayval] - if {$ansibase ne ""} { - #set displayval [::textblock::ansibase_lines $displayval $ansibase] - set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] - } - } - 4 { - set displayval $ansibase[ansistring VIEWSTYLE $displayval] - if {$ansibase ne ""} { - #set displayval [::textblock::ansibase_lines $displayval $ansibase] - set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] - } - } - } - - if {![string length $more]} { - puts $channel "$displaycount$label$displayval[a]" - } else { - puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" - } - return $val - } - - - - #return list of {chan chunk} elements - proc help_chunks {args} { - set chunks [list] - set linesep [string repeat - 76] - set mascotblock "" - catch { - package require patternpunk - #lappend chunks [list stderr [>punk . rhs]] - append mascotblock [textblock::frame -checkargs 0 [>punk . banner -title "Punk Shell" -left Tcl -right [package provide Tcl]]] - } - - set topic [lindex $args end] - set argopts [lrange $args 0 end-1] - - - set title "[a+ brightgreen] Punk core navigation commands: " - - #todo - load from source code annotation? - set cmdinfo [list] - lappend cmdinfo [list help "?topics?" "This help. To see available subitems type: help topics"] - lappend cmdinfo [list i "cmd ?subcommand...?" "Show usage for a command or ensemble subcommand"] - lappend cmdinfo [list s "cmd ?subcommand...?" "Show synopsis for a command or ensemble subcommand"] - lappend cmdinfo [list ./ "?subdir?" "view/change directory"] - lappend cmdinfo [list ../ "" "go up one directory"] - lappend cmdinfo [list ./new "subdir" "make new directory and switch to it"] - lappend cmdinfo [list n/ "?glob...?" "view/change namespace\n (accepts ns path globs e.g **::*get* to match comands at any level )"] - lappend cmdinfo [list n// "" "view/change namespace (with command listing)"] - lappend cmdinfo [list "nn/" "" "go up one namespace"] - lappend cmdinfo [list "n/new" "" "make child namespace and switch to it"] - lappend cmdinfo [list dev "?subcommand?" "(ensemble command to make new projects/modules and to generate docs)"] - lappend cmdinfo [list a? "?subcommand...?" "view ANSI colours\n e.g a? web"] - - #set cmds [lsearch -all -inline -index 0 -subindices $cmdinfo *] - #set descr [lsearch -all -inline -index 1 -subindices $cmdinfo *] - #set widest1 [tcl::mathfunc::max {*}[lmap v $cmds {string length $v}]] - #set widest2 [tcl::mathfunc::max {*}[lmap v $descr {string length $v}]] - set t [textblock::class::table new -show_seps 0] - #foreach c $cmds d $descr { - # $t add_row [list $c $d] - #} - foreach row $cmdinfo { - $t add_row $row - } - set width_0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$width_0 + 2}] - set width_1 [$t column_datawidth 1] - $t configure_column 1 -minwidth [expr {$width_1 + 1}] - $t configure -title $title - - set text "" - append text [$t print] - - - set warningblock "" - set introblock $mascotblock - append introblock \n $text - - #if {[catch {package require textblock} errM]} { - # append warningblock \n "WARNING: textblock package couldn't be loaded. Side-by-side display not available" - #} else { - # set introblock [textblock::join -- " " \n$mascotblock " " $text] - #} - - - lappend chunks [list stdout $introblock] - - - if {$topic in [list tcl]} { - if {[punk::lib::check::has_tclbug_script_var]} { - append warningblock \n "minor warning: punk::lib::check::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" - } - if {[punk::lib::check::has_tclbug_safeinterp_compile]} { - set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_safeinterp returned true!" \n - append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n - append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/1095bf7f75]" - append warningblock [a] - } - if {[punk::lib::check::has_tclbug_lsearch_strideallinline]} { - set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_lsearch_strideallinline returned true!" \n - append warningblock "${indent}(lsearch using -stride -all -inline -subindices does not return values corresponding to subindex when a single -index value is used)" \n - append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/5a1aaa201d]" - append warningblock [a] - } - if {[punk::lib::check::has_tclbug_list_quoting_emptyjoin]} { - set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_list_quoting returned true!" \n - append warningblock "${indent}lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" \n - append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/e38dce74e2]" - } - } - - set text "" - if {$topic in [list env environment]} { - #todo - move to punk::config? - upvar ::punk::config::punk_env_vars_config punkenv_config - upvar ::punk::config::other_env_vars_config otherenv_config - - set known_punk [dict keys $punkenv_config] - set known_other [dict keys $otherenv_config] - append text \n - set usetable 1 - if {$usetable} { - set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] - if {"windows" eq $::tcl_platform(platform)} { - #If any env vars have been set to empty string - this is considered a deletion of the variable on windows. - #The Tcl ::env array is linked to the underlying process view of the environment - #- but info exists ::env(var) can misreport as true if it has been deleted by setting to empty string rather than using unset. - #an 'array get' will resynchronise. - #Even if an env variable didn't exist before - setting it to empty string can get it to this inconsistent state. - array get ::env - } - #do an array read on ::env - foreach {v vinfo} $punkenv_config { - if {[info exists ::env($v)]} { - set c2 [set ::env($v)] - } else { - set c2 "(NOT SET)" - } - set help "" - if {[dict exists $vinfo help]} { - set help [dict get $vinfo help] - } - $t add_row [list $v $c2 $help] - } - $t configure_column 0 -headers [list "Punk environment vars"] - $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} - - set punktable [$t print] - $t destroy - - set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] - foreach {v vinfo} $otherenv_config { - if {[info exists ::env($v)]} { - set env_val [set ::env($v)] - if {[string match "*_TM_PATH" $v]} { - set entries [split $env_val $::tcl_platform(pathSeparator)] - set c2 [join $entries \n] - } else { - set c2 $::env($v) - } - } else { - set c2 "(NOT SET)" - } - $t add_row [list $v $c2] - } - $t configure_column 0 -headers [list "Other environment vars"] - $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} - - set othertable [$t print] - $t destroy - #append text [textblock::join -- $punktable " " $othertable]\n - append text $punktable\n$othertable\n - } else { - - append text $linesep\n - append text "punk environment vars:\n" - append text $linesep\n - set col1 [string repeat " " 25] - set col2 [string repeat " " 50] - foreach v $known_punk { - set c1 [overtype::left $col1 $v] - if {[info exists ::env($v)]} { - set c2 [overtype::left $col2 [set ::env($v)]] - } else { - set c2 [overtype::right $col2 "(NOT SET)"] - } - append text "$c1 $c2\n" - } - append text $linesep\n - } - - lappend chunks [list stdout $text] - } - - if {$topic in [list console terminal]} { - set indent [string repeat " " [string length "WARNING: "]] - lappend cstring_tests [dict create\ - type "PM "\ - msg "UN"\ - f7 punk::ansi::controlstring_PM\ - f7prefix "7bit ESC ^ secret "\ - f7suffix "safe"\ - f8 punk::ansi::controlstring_PM8\ - f8prefix "8bit \\x9e secret "\ - f8suffix "safe"\ - ] - lappend cstring_tests [dict create\ - type SOS\ - msg "NOT"\ - f7 punk::ansi::controlstring_SOS\ - f7prefix "7bit ESC X string "\ - f7suffix " hidden"\ - f8 punk::ansi::controlstring_SOS8\ - f8prefix "8bit \\x98 string "\ - f8suffix " hidden"\ - ] - lappend cstring_tests [dict create\ - type APC\ - msg "NOT"\ - f7 punk::ansi::controlstring_APC\ - f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\ - f7suffix " hidden"\ - f8 punk::ansi::controlstring_APC8\ - f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\ - f8suffix " hidden"\ - ] - - foreach test $cstring_tests { - set m [[dict get $test f7] [dict get $test msg]] - set hidden_width_m [punk::console::test_char_width $m] - set m8 [[dict get $test f8] [dict get $test msg]] - set hidden_width_m8 [punk::console::test_char_width $m8] - if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { - if {$hidden_width_m == 0} { - set d "[a+ green bold][dict get $test f7prefix][a red]${m}[a][a+ green bold][dict get $test f7suffix][a]" - } else { - set d "[a+ yellow bold][dict get $test f7prefix][a red]$m[a][a+ yellow bold][dict get $test f7suffix][a]" - } - if {$hidden_width_m8 == 0} { - set d8 "[a+ green ][dict get $test f8prefix][a red]$m8[a][a+ green][dict get $test f8suffix][a]" - } else { - set d8 "[a+ yellow bold][dict get $test f8prefix][a red]$m8[a][a+ yellow bold][dict get $test f8suffix][a]" - } - append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" - } - } - if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { - if {$result} { - append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." - append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." - append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" - append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" - append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" - } - } else { - append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" - } - - if {![catch {punk::console::check::has_bug_zwsp} result]} { - if {$result} { - append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." - append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" - } - } else { - append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" - } - - - set grapheme_support [punk::console::grapheme_cluster_support] - #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) - if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported" } { - append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." - if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { - append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" - } - } else { - if {![dict get $grapheme_support available]} { - switch -- [dict get $grapheme_support mode] { - "unset" { - append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." - } - "permanently_unset" { - append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." - } - "BAD_RESPONSE" { - append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." - } - } - } - } - - } - - lappend chunks [list stderr $warningblock] - if {$topic in [list topics help]} { - set text "" - set topics [dict create\ - "topics|help" "List help topics"\ - "tcl" "Tcl version warnings"\ - "env|environment" "punkshell environment vars"\ - "console|terminal" "Some console behaviour tests and warnings"\ - ] - - set t [textblock::class::table new -show_seps 0] - $t add_column -headers [list "Topic"] - $t add_column - foreach {k v} $topics { - $t add_row [list $k $v] - } - set widest0 [$t column_datawidth 0] - $t configure_column 0 -minwidth [expr {$widest0 + 4}] - append text \n[$t print] - - lappend chunks [list stdout $text] - } - - return $chunks - } - proc help {args} { - set chunks [help_chunks {*}$args] - foreach chunk $chunks { - lassign $chunk chan text - puts -nonewline $chan $text - } - } - proc mode {{raw_or_line query}} { - package require punk::console - tailcall ::punk::console::mode $raw_or_line - } - - #this hides windows cmd's mode command - probably no big deal - anyone who needs it will know how to exec it. - interp alias {} mode {} punk::mode - - proc aliases {{glob *}} { - tailcall punk::lib::aliases $glob - } - proc alias {{aliasorglob ""} args} { - tailcall punk::lib::alias $aliasorglob {*}$args - } - - - #pipeline-toys - put in lib/scriptlib? - ##geometric mean - #alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#| - - - - - - #interp alias {} c {} clear ;#external executable 'clear' may not always be available - #todo - review - interp alias {} clear {} ::punk::reset - interp alias {} c {} ::punk::reset - proc reset {} { - if {[llength [info commands ::punk::repl::reset_terminal]]} { - #punk::repl::reset_terminal notifies prompt system of reset - punk::repl::reset_terminal - } else { - puts -nonewline stdout [punk::ansi::reset] - } - } - - - - #fileutil::cat except with checking for windows illegal path names (when on windows platform) - interp alias {} fcat {} punk::mix::util::fcat - - #---------------------------------------------- - interp alias {} linelistraw {} punk::linelistraw - - # 'path' collides with kettle path in kettle::doc function - todo - patch kettle? - interp alias {} PATH {} punk::path - - interp alias {} path_list {} punk::path_list - interp alias {} list_filter_cond {} punk::list_filter_cond - - - interp alias {} inspect {} punk::inspect - interp alias {} ooinspect {} punk::ooinspect - - interp alias {} linedict {} punk::linedict - interp alias {} dictline {} punk::dictline - - #todo - pipepure - evaluate pipeline in a slave interp without commands that have side-effects. (safe interp?) - interp alias {} % {} punk::% - interp alias {} pipeswitch {} punk::pipeswitch - interp alias {} pipeswitchc {} punk::pipeswitchc ;#closure version - more correct - interp alias {} pipecase {} punk::pipecase - interp alias {} pipematch {} punk::pipematch - interp alias {} ispipematch {} punk::ispipematch - interp alias {} pipenomatchvar {} punk::pipenomatchvar - interp alias {} pipedata {} punk::pipedata - interp alias {} pipeset {} punk::pipeset - interp alias {} pipealias {} punk::pipealias - interp alias {} listset {} punk::listset ;#identical to pipeset - - - #non-core aliases - interp alias {} is_list_all_in_list {} punk::lib::is_list_all_in_list - interp alias {} is_list_all_ni_list {} punk::libis_list_all_ni_list - - - - #interp alias {} = {} ::punk::pipeline = "" "" - #interp alias {} = {} ::punk::match_assign "" "" - interp alias {} .= {} ::punk::pipeline .= "" "" - #proc .= {args} { - # #uplevel 1 [list ::punk::pipeline .= "" "" {*}$args] - # tailcall ::punk::pipeline .= "" "" {*}$args - #} - - - interp alias {} rep {} ::tcl::unsupported::representation - interp alias {} dis {} ::tcl::unsupported::disassemble - - - - # ls aliases - note that tcl doesn't exand * but sh_xxx functions pass to sh -c allowing shell expansion - interp alias {} l {} sh_runout -n ls -A ;#plain text listing - #interp alias {} ls {} sh_runout -n ls -AF --color=always - interp alias {} ls {} shellrun::runconsole ls -AF --color=always ;#use unknown to use terminal and allow | more | less - #note that shell globbing with * won't work on unix systems when using unknown/exec - interp alias {} lw {} sh_runout -n ls -AFC --color=always ;#wide listing (use A becaus no extra info on . & ..) - interp alias {} ll {} sh_runout -n ls -laFo --color=always ;#use a instead of A to see perms/owner of . & .. - # -v for natural number sorting not supported on freeBSD. Todo - test at startup and modify aliases? - #interp alias {} lw {} ls -aFv --color=always - - interp alias {} dir {} shellrun::runconsole dir - - # punk::nav::fs - package require punk::nav::fs - interp alias {} ./ {} punk::nav::fs::d/ - interp alias {} ../ {} punk::nav::fs::dd/ - interp alias {} d/ {} punk::nav::fs::d/ - interp alias {} dd/ {} punk::nav::fs::dd/ - - interp alias {} vwd {} punk::nav::fs::vwd ;#return punk::nav::fs::VIRTUAL_CWD - and report to stderr pwd if different - interp alias {} dirlist {} punk::nav::fs::dirlist - interp alias {} dirfiles {} punk::nav::fs::dirfiles - interp alias {} dirfiles_dict {} punk::nav::fs::dirfiles_dict - - interp alias {} ./new {} punk::nav::fs::d/new - interp alias {} d/new {} punk::nav::fs::d/new - interp alias {} ./~ {} punk::nav::fs::d/~ - interp alias {} d/~ {} punk::nav::fs::d/~ - interp alias "" x/ "" punk::nav::fs::x/ - - variable pshell_path "" - # ---------------------------------------- - set pshell_path [auto_execok pwsh] ;#Still not installed by default on win10 11? - if {$pshell_path eq ""} { - #fallback to powershell 5 - #set pshell_path [auto_execok powershell] - set pshell_path powershell ;#temp - } else { - set pshell_path pwsh ;#temp - } - #todo - review run commands and handling of paths with spaces - # ---------------------------------------- - - - - if {$pshell_path eq ""} { - set has_powershell 0 - } else { - #todo - review powershell detection on non-windows platforms - set has_powershell 1 - } - - if {$::tcl_platform(platform) eq "windows"} { - interp alias {} dl {} dir /q - interp alias {} dw {} dir /W/D - } else { - #todo - natsorted equivalent - #interp alias {} dl {} - interp alias {} dl {} puts stderr "not implemented" - interp alias {} dw {} puts stderr "not implemented" - } - - #todo - distinguish non-preinstalled pwsh (powershell core) from powershell which is available by default - if {$has_powershell} { - #see also powershell runspaces etc: - # powershell runspaces e.g $rs=[RunspaceFactory]::CreateRunspace() - # $ps = [Powershell]::Create() - - interp alias {} pse {} exec >@stdout {*}$pshell_path -nolo -nop -c - interp alias {} psx {} runx -n {*}$pshell_path -nop -nolo -c - interp alias {} psr {} run -n {*}$pshell_path -nop -nolo -c - interp alias {} psout {} runout -n {*}$pshell_path -nop -nolo -c - interp alias {} pserr {} runerr -n {*}$pshell_path -nop -nolo -c - #interp alias {} psls {} shellrun::runconsole $pshell_path -nop -nolo -c ls - #interp alias {} psls {} shellrun::runconsole {*}$pshell_path -nop -nolo -c {ls | Select-Object Mode, @{Name='Owner';Expression={(Get-Acl $_.FullName).Owner}}, LastWriteTime, Length, Name | Format-Table} - proc psls args { - variable pshell_path - shellrun::runconsole {*}$pshell_path -nop -nolo -c {*}[string map [list %a% $args] {{ls %a% | Select-Object Mode, @{Name='Owner';Expression={(Get-Acl $_.FullName).Owner}}, LastWriteTime, Length, Name | Format-Table}}] - } - interp alias {} psls {} punk::psls - interp alias {} psps {} shellrun::runconsole {*}$pshell_path -nop -nolo -c ps - } else { - set ps_missing "powershell missing (powershell is MIT licensed open source and can be installed on windows and most unix-like platforms)" - interp alias {} pse {} puts stderr $ps_missing - interp alias {} psx {} puts stderr $ps_missing - interp alias {} psr {} puts stderr $ps_missing - interp alias {} psout {} puts stderr $ps_missing - interp alias {} pserr {} puts stderr $ps_missing - interp alias {} psls {} puts stderr $ps_missing - interp alias {} psps {} puts stderr $ps_missing - } - proc psencode {cmdline} { - - } - proc psdecode {encodedcmd} { - - } - - proc repl {startstop} { - switch -- $startstop { - stop { - if {[punk::repl::codethread::is_running]} { - puts stdout "Attempting repl stop. Try ctrl-c or exit command to leave interpreter" - set ::repl::done 1 - } - } - start { - if {[punk::repl::codethread::is_running]} { - repl::start stdin - } - } - default { - error "repl unknown action '$startstop' - must be start or stop" - } - } - } - -} - - -# -- --- --- --- -#Load decks. commandset packages are not loaded until the deck is called. -# -- --- --- --- -package require punk::mod -#punk::mod::cli set_alias pmod -punk::mod::cli set_alias app - -#todo - change to punk::dev -package require punk::mix -punk::mix::cli set_alias dev -punk::mix::cli set_alias deck ;#deprecate! - -#todo - add punk::deck for managing cli modules and commandsets - -package require punkcheck::cli -punkcheck::cli set_alias pcheck -punkcheck::cli set_alias punkcheck -# -- --- --- --- - -package provide punk [namespace eval punk { - #FUNCTL - variable version - set version 0.1 -}] - - - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm deleted file mode 100644 index b8fada0b..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ /dev/null @@ -1,346 +0,0 @@ -# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) 2024 -# -# @@ Meta Begin -# Application punk::aliascore 0.1.0 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::aliascore 0 0.1.0] -#[copyright "2024"] -#[titledesc {punkshell command aliases}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require punk::aliascore] -#[keywords module alias] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of punk::aliascore -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::aliascore -#[list_begin itemized] - -package require Tcl 8.6- -#*** !doctools -#[item] [package {Tcl 8.6}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::aliascore::class { -# #*** !doctools -# #[subsection {Namespace punk::aliascore::class}] -# #[para] class definitions -# if {[info commands [namespace current]::interface_sample1] eq ""} { -# #*** !doctools -# #[list_begin enumerated] -# -# # oo::class create interface_sample1 { -# # #*** !doctools -# # #[enum] CLASS [class interface_sample1] -# # #[list_begin definitions] -# -# # method test {arg1} { -# # #*** !doctools -# # #[call class::interface_sample1 [method test] [arg arg1]] -# # #[para] test method -# # puts "test: $arg1" -# # } -# -# # #*** !doctools -# # #[list_end] [comment {-- end definitions interface_sample1}] -# # } -# -# #*** !doctools -# #[list_end] [comment {--- end class enumeration ---}] -# } -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::aliascore { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase - variable aliases - #use absolute ns ie must be prefixed with :: - #single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased - - #functions should generally be covered by one of the export patterns of their source namespace - # - if they are not - e.g (separately loaded ensemble command ?) - # the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were. - set aliases [tcl::dict::create\ - val ::punk::pipe::val\ - aliases ::punk::lib::aliases\ - alias ::punk::lib::alias\ - tstr ::punk::lib::tstr\ - list_as_lines ::punk::lib::list_as_lines\ - lines_as_list ::punk::lib::lines_as_list\ - linelist ::punk::lib::linelist\ - linesort ::punk::lib::linesort\ - pdict ::punk::lib::pdict\ - plist {::punk::lib::pdict -roottype list}\ - showlist {::punk::lib::showdict -roottype list}\ - grepstr ::punk::grepstr\ - rehash ::punk::rehash\ - showdict ::punk::lib::showdict\ - ansistrip ::punk::ansi::ansistrip\ - stripansi ::punk::ansi::ansistrip\ - ansiwrap ::punk::ansi::ansiwrap\ - colour ::punk::console::colour\ - color ::punk::console::colour\ - ansi ::punk::console::ansi\ - a? ::punk::console::code_a?\ - A? {::punk::console::code_a? forcecolor}\ - a+ ::punk::console::code_a+\ - A+ {::punk::console::code_a+ forcecolour}\ - a ::punk::console::code_a\ - A {::punk::console::code_a forcecolour}\ - smcup ::punk::console::enable_alt_screen\ - rmcup ::punk::console::disable_alt_screen\ - config ::punk::config\ - s ::punk::ns::synopsis\ - eg ::punk::ns::eg\ - ] - - #*** !doctools - #[subsection {Namespace punk::aliascore}] - #[para] Core API functions for punk::aliascore - #[list_begin definitions] - - - - #proc sample1 {p1 n args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 - # #[para] Arguments: - # # [list_begin arguments] - # # [arg_def tring p1] A description of string argument p1. - # # [arg_def integer n] A description of integer argument n. - # # [list_end] - # return "ok" - #} - - proc _is_exported {ns cmd} { - set exports [::tcl::namespace::eval $ns [list namespace export]] - set is_exported 0 - foreach p $exports { - if {[string match $p $cmd]} { - set is_exported 1 - break - } - } - return $is_exported - } - - #_nsprefix accepts entire command - not just an existing namespace for which we want the parent - proc _nsprefix {{nspath {}}} { - #maintenance: from punk::ns::nsprefix - (without unnecessary nstail) - #normalize the common case of :::: - set nspath [string map {:::: ::} $nspath] - set rawprefix [string range $nspath 0 end-[string length [namespace tail $nspath]]] - if {$rawprefix eq "::"} { - return $rawprefix - } else { - if {[string match *:: $rawprefix]} { - return [string range $rawprefix 0 end-2] - } else { - return $rawprefix - } - } - } - - #todo - options as to whether we should raise an error if collisions found, undo aliases etc? - proc init {args} { - set defaults {-force 0} - set opts [dict merge $defaults $args] - set opt_force [dict get $opts -force] - - #we never override existing aliases to ::repl::interp* even if -force = 1 - #(these are our safebase aliases) - set ignore_pattern "::repl::interp*" - set ignore_aliases [list] - - variable aliases - set existing [list] - set conflicts [list] - foreach {a cmd} $aliases { - if {[tcl::info::commands ::$a] ne ""} { - lappend existing $a - set existing_alias [interp alias "" $a] - if {$existing_alias ne ""} { - set existing_target $existing_alias - if {[string match $ignore_pattern $existing_target]} { - #don't consider it a conflict - will use ignore_aliases to exclude it below - lappend ignore_aliases $a - continue - } - } else { - if {[catch {tcl::namespace::origin $a} existing_command]} { - set existing_command "" - } - set existing_target $existing_command - } - - if {$existing_target ne $cmd} { - #command exists in global ns but doesn't match our defined aliases/imports - lappend conflicts $a - } - } - } - if {!$opt_force && [llength $conflicts]} { - error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" - } - - set failed [list] - set tempns ::temp_[info cmdcount] ;#temp ns for renames - dict for {a cmd} $aliases { - #puts "aliascore $a -> $cmd" - if {$a in $ignore_aliases} { - continue - } - if {[llength $cmd] > 1} { - interp alias {} $a {} {*}$cmd - } else { - if {[tcl::info::commands $cmd] ne ""} { - #todo - ensure exported? noclobber? - set container_ns [_nsprefix $cmd] - set cmdtail [tcl::namespace::tail $cmd] - set was_exported 1 ;#assumption - if {![_is_exported $container_ns $cmdtail]} { - set was_exported 0 - set existing_exports [tcl::namespace::eval $container_ns [list ::namespace export]] - tcl::namespace::eval $container_ns [list ::namespace export $cmdtail] - } - if {[tcl::namespace::tail $a] eq $cmdtail} { - #puts stderr "importing $cmd" - try { - tcl::namespace::eval :: [list ::namespace import $cmd] - } trap {} {emsg eopts} { - lappend failed [list alias $a target $cmd errormsg $emsg] - } - } else { - #target command name differs from exported name - #e.g stripansi -> punk::ansi::ansistrip - #import and rename - #puts stderr "importing $cmd (with rename to ::$a)" - try { - tcl::namespace::eval $tempns [list ::namespace import $cmd] - } trap {} {emsg eopst} { - lappend failed [list alias $a target $cmd errormsg $emsg] - } - catch {rename ${tempns}::$cmdtail ::$a} - } - #restore original exports - if {!$was_exported} { - tcl::namespace::eval $container_ns [list ::namespace export -clear {*}$existing_exports] - } - } else { - interp alias {} $a {} {*}$cmd - } - } - } - #tcl::namespace::delete $tempns - return [dict create aliases [dict keys $aliases] existing $existing ignored $ignore_aliases changed $conflicts failed $failed] - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::aliascore ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#interp alias {} list_as_lines {} punk::lib::list_as_lines -#interp alias {} lines_as_list {} punk::lib::lines_as_list -#interp alias {} ansistrip {} punk::ansi::ansistrip ;#review -#interp alias {} linelist {} punk::lib::linelist ;#critical for = assignment features -#interp alias {} linesort {} punk::lib::linesort - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval punk::aliascore::lib { - namespace export {[a-z]*} ;# Convention: export all lowercase - namespace path [namespace parent] - #*** !doctools - #[subsection {Namespace punk::aliascore::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 punk::aliascore::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -namespace eval punk::aliascore::system { - #*** !doctools - #[subsection {Namespace punk::aliascore::system}] - #[para] Internal functions that are not part of the API - - - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::aliascore [namespace eval punk::aliascore { - variable pkg punk::aliascore - variable version - set version 0.1.0 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm deleted file mode 100644 index 15421402..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ /dev/null @@ -1,8727 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# 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) 2023 -# -# @@ Meta Begin -# Application punk::ansi 0.1.1 -# Meta platform tcl -# Meta license -# @@ Meta End - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::ansi 0 0.1.1] -#[copyright "2023"] -#[titledesc {Ansi string functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk Ansi library}] [comment {-- Description at end of page heading --}] -#[require punk::ansi] -#[keywords module ansi terminal console string] -#[description] -#[para]Ansi based terminal control string functions -#[para]See [package punk::ansi::console] for related functions for controlling a console - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of punk::ansi -#[para]punk::ansi functions return their values - no implicit emission to console/stdout -#[subsection Concepts] -#[para]Ansi codes can be used to control most terminals on most platforms in an 'almost' standard manner -#[para]There are many differences in terminal implementations - but most should support a core set of features -#[para]punk::ansi does not contain any code for direct terminal manipulation via the local system APIs. -#[para]Sticking to ansi codes where possible may be better for cross-platform and remote operation where such APIs are unlikely to be useable. - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::ansi -#[list_begin itemized] - -package require Tcl 8.6- -package require punk::char -package require punk::assertion -#*** !doctools -#[item] [package {Tcl 8.6-}] -#[item] [package {punk::char}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - - -tcl::namespace::eval punk::ansi::class { - if {![llength [tcl::info::commands class_ansi]]} { - - oo::class create class_ansi { - variable o_ansistringobj - - variable o_render_dimensions ;#last dimensions at which we rendered - variable o_rendered - variable o_rendered_what - constructor {ansitext {dimensions 80x25}} { - if {![regexp {^([0-9]+)[xX]([0-9]+)$} $dimensions _m w h]} { - error "class_ansi::render dimensions must be of the form x" - } - - #a straight string compare may be faster.. but a checksum is much smaller in memory, so we'll use that by default. - set o_rendered_what "" - #There may also be advantages to renering to a class_ansistring class object - - set o_render_dimensions $dimensions - set o_ansistringobj [ansistring NEW $ansitext] - } - method get {} { - return [$o_ansistringobj get] - } - method render {{dimensions ""}} { - if {$dimensions eq ""} { - set dimensions $o_render_dimensions - } - if {![regexp {^([0-9]+)[xX]([0-9]+)$} $dimensions _m w h]} { - error "class_ansi::render dimensions must be of the form x" - } - set cksum "not-done" - if {$dimensions ne $o_render_dimensions || $o_rendered_what ne [set cksum [$o_ansistringobj checksum]]} { - #some ansi layout/art relies on wrapping at the width-dimension to display properly - #this includes cursor movements ie right arrow can move cursor to columns in lines below - #overflow is a different concept - perhaps not particularly congruent with the idea of the textblock as a mini terminal emulator. - #overflow effectively auto-expands the block(terminal?) width - #overflow and wrap both being true won't make sense unless we implement a max_overflow concept - set o_rendered [overtype::renderspace -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] - if {$cksum eq "not-done"} { - #if dimensions changed - the checksum won't have been done - set o_rendered_what [$o_ansistringobj checksum] - } else { - set o_rendered_what $cksum - } - set o_render_dimensions $dimensions - } - - #todo - store rendered and allow partial rendering of new data lines? - return $o_rendered - } - method rendertest {{dimensions ""}} { - if {$dimensions eq ""} { - set dimensions $o_render_dimensions - } - if {![regexp {^([0-9]+)[xX]([0-9]+)$} $dimensions _m w h]} { - error "class_ansi::render dimensions must be of the form x" - } - set o_dimensions $dimensions - - - set rendered [overtype::renderspace -cp437 1 -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] - return $rendered - } - - lappend ::punk::ansi::class::PUNKARGS [list { - @id -id "::punk::ansi::class::class_ansi render_to_input_line" - @cmd -name "punk::ansi::class::class_ansi render_to_input_line" -help\ - "render string from line 0 to line - (experimental/debug)" - -dimensions -type string -help\ - "WxH where W is integer width >= 1 and H is integer heigth >= 1" - -minus -type integer -help\ - "number of chars to exclude from end" - @values -min 1 -max 1 - line -type indexexpression - }] - method render_to_input_line {args} { - if {[llength $args] < 1} { - puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args - } - set x [lindex $args end] - set arglist [lrange $args 0 end-1] - if {[llength $arglist] %2 != 0} { - puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args - } - set opts [tcl::dict::create\ - -dimensions 80x24\ - -minus 0\ - ] - foreach {k v} $arglist { - switch -- $k { - -dimensions - -minus { - tcl::dict::set opts $k $v - } - default { - puts stderr "render_to_input_line unexpected argument '$k' usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args - } - } - } - set opt_dimensions [tcl::dict::get $opts -dimensions] - set opt_minus [tcl::dict::get $opts -minus] - lassign [split $opt_dimensions x] w h - if {![tcl::string::is integer -strict $w] || ![tcl::string::is integer -strict $h] || $w < 1 || $h < 1} { - puts stderr "render_to_input_line WxH width & height must be positive integer values usage: ?-dimensions WxH? ?-minus charcount? x" - } - if {![tcl::string::is integer -strict $opt_minus]} { - puts stderr "render_to_input_line -minus must be positive integer value representing number of chars to exclude from end. usage: ?-dimensions WxH? ?-minus charcount? x" - } - - package require textblock - set lfvis [ansistring VIEW -lf 1 \n] - set maplf [list \n "[a+ green bold reverse]${lfvis}[a]\n"] ;#a mapping to highlight newlines - - set lines [split [$o_ansistringobj get] \n] - set rlines [lrange $lines 0 $x] - set chunk [::join $rlines \n] - append chunk \n - if {$opt_minus ne "0"} { - set chunk [tcl::string::range $chunk 0 end-$opt_minus] - } - set rendered [overtype::renderspace -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk] - set marker "" - for {set i 1} {$i <= $w} {incr i} { - if {$i % 10 == 0} { - ::append marker "|" - } elseif {$i % 5 == 0} { - ::append marker * - } else { - ::append marker "." - } - } - ::append rendered \n $marker - set xline [lindex $rlines $x]\n - set xlinev [ansistring VIEWSTYLE $xline] - set xlinev [tcl::string::map $maplf $xlinev] - set xlinedisplay [overtype::renderspace -wrap 1 -width $w -height 1 "" $xlinev] - ::append rendered \n $xlinedisplay - - set chunk [ansistring VIEWSTYLE $chunk] - set chunk [tcl::string::map $maplf $chunk] - #keep chunkdisplay narrower - leave at 80 or it will get unwieldy for larger image widths - set chunkdisplay [overtype::renderspace -wrap 1 -width 80 -height 1 "" $chunk] - set renderheight [llength [split $rendered \n]] - set chunkdisplay_lines [split $chunkdisplay \n] - set chunkdisplay_tail [lrange $chunkdisplay_lines end-$renderheight end] - set chunkdisplay_block [join $chunkdisplay_tail \n] - #the input chunk lines are often much longer than the output.. resulting in main content being way up the screen. It's often impractical to view more than the tail of the chunkdisplay. - textblock::join -- $rendered $chunkdisplay_block - } - - method checksum {} { - return [$o_ansistringobj checksum] - } - method checksum_last_rendered_input {} { - return $o_rendered_what - } - #todo - fix class_ansistring so the ansistring methods can be called directly - method viewlines {} { - return [ansistring VIEW [$o_ansistringobj get]] - } - method viewcodes {args} { - set defaults [list\ - -lf 0\ - -vt 0\ - -width "auto"\ - ] - set opts $defaults - foreach {k v} $args { - switch -- $k { - -lf - -vt - -width { - tcl::dict::set opts $k $v - } - default { - error "viewcodes unrecognised option '$k'. Known options [tcl::dict::keys $defaults]" - } - } - } - set opts_lf [tcl::dict::get $opts -lf] - set opts_vt [tcl::dict::get $opts -vt] - set opts_width [tcl::dict::get $opts -width] - if {$opts_width eq ""} { - return [ansistring VIEWCODES -lf $opts_lf -vt $opts_vt [$o_ansistringobj get]] - } elseif {$opts_width eq "auto"} { - lassign [punk::console::get_size] _cols columns _rows rows - set displaycols [expr {$columns -4}] ;#review - return [overtype::renderspace -width $displaycols -wrap 1 "" [ansistring VIEWCODES -lf $opts_lf -vt $opts_vt [$o_ansistringobj get]]] - } elseif {[tcl::string::is integer -strict $opts_width] && $opts_width > 0} { - return [overtype::renderspace -width $opts_width -wrap 1 "" [ansistring VIEWCODES -lf $opts_lf -vt $opts_vt [$o_ansistringobj get]]] - } else { - error "viewcodes unrecognised value for -width. Try auto or a positive integer" - } - } - method viewchars {args} { - set defaults [list\ - -width "auto"\ - ] - set opts $defaults - foreach {k v} $args { - switch -- $k { - -width { - tcl::dict::set opts $k $v - } - default { - error "viewchars unrecognised option '$k'. Known options [tcl::dict::keys $defaults]" - } - } - } - set opts_width [tcl::dict::get $opts -width] - if {$opts_width eq ""} { - return [punk::ansi::ansistripraw [$o_ansistringobj get]] - } elseif {$opts_width eq "auto"} { - lassign [punk::console::get_size] _cols columns _rows rows - set displaycols [expr {$columns -4}] ;#review - return [overtype::renderspace -width $displaycols -wrap 1 "" [punk::ansi::ansistripraw [$o_ansistringobj get]]] - } elseif {[tcl::string::is integer -strict $opts_width] && $opts_width > 0} { - return [overtype::renderspace -width $opts_width -wrap 1 "" [punk::ansi::ansistripraw [$o_ansistringobj get]]] - } else { - error "viewchars unrecognised value for -width. Try auto or a positive integer" - } - } - method viewstyle {args} { - set defaults [list\ - -width "auto"\ - ] - set opts $defaults - foreach {k v} $args { - switch -- $k { - -width { - tcl::dict::set opts $k $v - } - default { - error "viewstyle unrecognised option '$k'. Known options [tcl::dict::keys $defaults]" - } - } - } - set opts_width [tcl::dict::get $opts -width] - if {$opts_width eq ""} { - return [ansistring VIEWSTYLE [$o_ansistringobj get]] - } elseif {$opts_width eq "auto"} { - lassign [punk::console::get_size] _cols columns _rows rows - set displaycols [expr {$columns -4}] ;#review - return [overtype::renderspace -width $displaycols -wrap 1 "" [ansistring VIEWSTYLE [$o_ansistringobj get]]] - } elseif {[tcl::string::is integer -strict $opts_width] && $opts_width > 0} { - return [overtype::renderspace -width $opts_width -wrap 1 "" [ansistring VIEWSTYLE [$o_ansistringobj get]]] - } else { - error "viewstyle unrecognised value for -width. Try auto or a positive integer" - } - } - method append_noreturn {ansistring} { - $o_ansistringobj append $ansistring - #don't return the raw data - it may be big and probably won't play nicely with default terminal dimensions etc. - return - } - #like Tcl append - returns the result - #Tcl's append changes a variable state, this changes the object state - method append {ansistring} { - $o_ansistringobj append $ansistring - } - - } - } -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::ansi { - variable PUNKARGS - #*** !doctools - #[subsection {Namespace punk::ansi}] - #[para] Core API functions for punk::ansi - #[list_begin definitions] - - #old-school ansi graphics - C0 control glyphs. - variable cp437_map - #for cp437 images we need to map these *after* splitting ansi, to single-width unicode chars - #It would also probably be problematic to map \u000A to the glyph - as this is the newline - it included in the map anyway for completeness. The caller may have to manually carve that or other specific c0 controls out of the map to use it depending on the situation(?) - #Layout for cp437 won't be right if you don't at least set width of control-chars to 1 - but also some images specifically use these glyphs - #most fonts don't seem to supply graphics for these control characters even when cp437 is in use - the c1 control glyphs appear to be more widely available - but we could add them here too - #by mapping these we can display regardless. - #nul char - no cp437 image but commonly used as space in ansi graphics. - #(This is a potential conflict because we use nul as a filler to mean empty column in overtype rendering) REVIEW - tcl::dict::set cp437_map \u0000 " " ;#space - tcl::dict::set cp437_map \u0001 \u263A ;#smiley - tcl::dict::set cp437_map \u0002 \u263B ;#smiley-filled - tcl::dict::set cp437_map \u0003 \u2665 ;#heart - tcl::dict::set cp437_map \u0004 \u2666 ;#diamond - tcl::dict::set cp437_map \u0005 \u2663 ;#club - tcl::dict::set cp437_map \u0006 \u2660 ;#spade - tcl::dict::set cp437_map \u0007 \u2022 ;#dot - tcl::dict::set cp437_map \u0008 \u25D8 ;#square hollow dot - tcl::dict::set cp437_map \u0009 \u25CB ;#hollow dot - tcl::dict::set cp437_map \u000A \u25D9 ;#square and dot (\n) - tcl::dict::set cp437_map \u000B \u2642 ;#male - tcl::dict::set cp437_map \u000C \u2640 ;#female - tcl::dict::set cp437_map \u000D \u266A ;#note1 (\r) - tcl::dict::set cp437_map \u000E \u266B ;#note2 - tcl::dict::set cp437_map \u000F \u263C ;#sun - tcl::dict::set cp437_map \u0010 \u25BA ;#right arrow triangle - tcl::dict::set cp437_map \u0011 \u25CA ;#left arrow triangle - tcl::dict::set cp437_map \u0012 \u2195 ;#updown arrow - tcl::dict::set cp437_map \u0013 \u203C ;#double bang - tcl::dict::set cp437_map \u0014 \u00B6 ;#pilcrow (paragraph mark / blind P) - tcl::dict::set cp437_map \u0015 \u00A7 ;#Section Sign - tcl::dict::set cp437_map \u0016 \u25AC ;#Heavy horizontal? - tcl::dict::set cp437_map \u0017 \u21A8 ;#updown arrow 2 ? - tcl::dict::set cp437_map \u0018 \u2191 ;#up arrow - tcl::dict::set cp437_map \u0019 \u2193 ;#down arrow - tcl::dict::set cp437_map \u001A \u2192 ;#right arrow - tcl::dict::set cp437_map \u001B \u2190 ;#left arrow - tcl::dict::set cp437_map \u001C \u221F ;#bottom left corner - tcl::dict::set cp437_map \u001D \u2194 ;#left-right arrow - tcl::dict::set cp437_map \u001E \u25B2 ;#up arrow triangle - tcl::dict::set cp437_map \u001F \u25BC ;#down arrow triangle - - variable map_special_graphics - #DEC Special Graphics set https://en.wikipedia.org/wiki/DEC_Special_Graphics - #AKA IBM Code page 1090 - tcl::dict::set map_special_graphics _ \u00a0 ;#no-break space - tcl::dict::set map_special_graphics "`" \u25c6 ;#black diamond - tcl::dict::set map_special_graphics a \u2592 ;#shaded block (checkerboard stipple), medium shade - Block Elements - tcl::dict::set map_special_graphics b \u2409 ;#symbol for HT - tcl::dict::set map_special_graphics c \u240c ;#symbol for FF - tcl::dict::set map_special_graphics d \u240d ;#symbol for CR - tcl::dict::set map_special_graphics e \u240a ;#symbol for LF - tcl::dict::set map_special_graphics f \u00b0 ;#degree sign - tcl::dict::set map_special_graphics g \u00b1 ;#plus-minus sign - tcl::dict::set map_special_graphics h \u2424 ;#symbol for NL - tcl::dict::set map_special_graphics i \u240b ;#symbol for VT - tcl::dict::set map_special_graphics j \u2518 ;#brc, light up and left - box drawing - tcl::dict::set map_special_graphics k \u2510 ;#trc, light down and left - box drawing - tcl::dict::set map_special_graphics l \u250c ;#tlc, light down and right - box drawing - tcl::dict::set map_special_graphics m \u2514 ;#blc, light up and right - box drawing - tcl::dict::set map_special_graphics n \u253c ;#light vertical and horizontal - box drawing - tcl::dict::set map_special_graphics o \u23ba ;#horizontal scan line-1 - tcl::dict::set map_special_graphics p \u23bb ;#horizontal scan line-3 - tcl::dict::set map_special_graphics q \u2500 ;#light horizontal - box drawing - tcl::dict::set map_special_graphics r \u23bc ;#horizontal scan line-7 - tcl::dict::set map_special_graphics s \u23bd ;#horizontal scan line-9 - tcl::dict::set map_special_graphics t \u251c ;#light vertical and right - box drawing - tcl::dict::set map_special_graphics u \u2524 ;#light vertical and left - box drawing - tcl::dict::set map_special_graphics v \u2534 ;#light up and horizontal - box drawing - tcl::dict::set map_special_graphics w \u252c ;#light down and horizontal - box drawing - tcl::dict::set map_special_graphics x \u2502 ;#light vertical - box drawing - tcl::dict::set map_special_graphics y \u2264 ;#less than or equal - tcl::dict::set map_special_graphics z \u2265 ;#greater than or equal - tcl::dict::set map_special_graphics "\{" \u03c0 ;#greek small letter pi - tcl::dict::set map_special_graphics "|" \u2260 ;#not equal to - tcl::dict::set map_special_graphics "\}" \u00a3 ;#pound sign - tcl::dict::set map_special_graphics ~ \u00b7 ;#middle dot - - #see also ansicolour page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control - - variable test "blah\033\[1;33mETC\033\[0;mOK" - - #Note that a? is actually a pattern. We can't explicitly match it without also matcing a+ ab etc. Presumably this won't matter here. - tcl::namespace::export\ - {a?} {a+} a \ - ansistring\ - ansiwrap\ - convert*\ - clear*\ - cursor_*\ - delete*\ - detect*\ - erase*\ - get_*\ - hyperlink\ - hyperlink_open\ - hyperlink_close\ - move*\ - reset*\ - ansistrip*\ - test_decaln\ - titleset\ - - - variable escape_terminals - #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). - tcl::dict::set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] - #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - tcl::dict::set escape_terminals OSC [list \007 \033\\ \u009c] ;#note mix of 1 and 2-byte terminals - tcl::dict::set escape_terminals DCS [list \007 \033\\ \u009c] - tcl::dict::set escape_terminals MISC [list \007 \033\\ \u009c] - #NOTE - we are assuming an OSC or DCS started with one type of sequence (7 or 8bit) can be terminated by either 7 or 8 bit ST (or BEL e.g wezterm ) - #This using a different type of ST to that of the opening sequence is presumably unlikely in the wild - but who knows? - - #review - there doesn't seem to be an \x1b#7 - # https://espterm.github.io/docs/VT100%20escape%20codes.html - - #self-contained 2 byte ansi escape sequences - review more? - set ansi_2byte_codes_dict [tcl::dict::create\ - "reset_terminal" "\u001bc"\ - "save_cursor_posn" "\u001b7"\ - "restore_cursor_posn" "\u001b8"\ - "cursor_up_one" "\u001bM"\ - "NEL - Next Line" "\u001bE"\ - "IND - Down one line" "\u001bD"\ - "HTS - Set Tab Stop" "\u001bH"\ - "DECPAM app keypad" "\x1b="\ - "DECPNM norm keypad" "\x1b>"\ - ] - - - # -------------------------------------- - #comparitive test (performance) string-append vs 2-object (with existing splits) append - proc test_cat1 {ansi1 ansi2} { - #make sure objects have splits - set s1 [ansistring NEW $ansi1] - tcl::namespace::eval [info object namespace $s1] {my MakeSplit} - set s2 [ansistring NEW $ansi2] - tcl::namespace::eval [info object namespace $s2] {my MakeSplit} - - #operation under test - # -- - #standard string append - $s1 append $ansi2 - # -- - $s2 destroy - - #$s1 append \033\[31mX ;#redX - return $s1 - } - proc test_cat2 {ansi1 ansi2} { - #make sure objects have splits - set s1 [ansistring NEW $ansi1] - tcl::namespace::eval [info object namespace $s1] {my MakeSplit} - set s2 [ansistring NEW $ansi2] - tcl::namespace::eval [info object namespace $s2] {my MakeSplit} - - #operation under test - # -- - #ansistring object append - $s1 appendobj $s2 - # -- - $s2 destroy - #$s1 append \033\[31mX ;#redX - return $s1 - } - # -------------------------------------- - - - #review - We have file possibly encoded directly in another codepage such as 437 - or utf8,utf16 etc, but then still needing post conversion to e.g cp437? - #In testing old ansi graphics files available on the web, some files need encoding {utf-8 cp437} some just cp437 - proc readfile {fname {encoding cp437}} { - #todo - #1- look for BOM - read according to format given by BOM - #2- assume utf-8 - #3- if errors - assume cp437? - - if {[llength $encoding] == 1} { - set ansidata [fcat -encoding $encoding $fname] - set obj [punk::ansi::class::class_ansi new $ansidata] - } elseif {[llength $encoding] == 2} { - set ansidata [fcat -encoding [lindex $encoding 0] $fname] - set ansidata [encoding convertfrom [lindex $encoding 1] $ansidata] - set obj [punk::ansi::class::class_ansi new $ansidata] - } else { - error "encoding list '$encoding' not supported. Use 1 or 2 encodings (first for file read, second as encoding convertfrom)" - } - return $obj - } - proc ansicat {fname args} { - set encnames [encoding names] - set encoding "" - set dimensions "" - foreach a $args { - if {$a in $encnames} { - set encoding $a - } else { - if {[regexp {[0-9]+(?:x|X)[0-9]+} $a]} { - set dimensions $a - } - } - } - if {$encoding eq ""} { - set encoding cp437 - } - - if {$dimensions eq ""} { - set dimensions 80x24 - } - - set ansidata [fcat -encoding $encoding $fname] - set obj [punk::ansi::class::class_ansi new $ansidata] - if {$encoding eq "cp437"} { - set result [$obj rendertest $dimensions] - } else { - set result [$obj render $dimensions] - } - $obj destroy - return $result - } - #utf-8/ascii encoded cp437 - proc ansicat2 {fname {encoding utf-8}} { - set data [fcat -encoding $encoding $fname] - set ansidata [encoding convertfrom cp437 $data] - set obj [punk::ansi::class::class_ansi new $ansidata] - set result [$obj render] - $obj destroy - return $result - } - - proc Get_ansifolder {} { - if {[catch {punk::repo::find_project} base]} { - set base "" - } - if {$base eq ""} { - #pwd not avail in safe interp - if {![catch {pwd} CWD]} { - set base $CWD - } - } - if {[info commands file] eq ""} { - #probably a safe interp - return "UNAVAILABLE" - } - return [file join $base src/testansi] - } - - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::ansi::example - @cmd -name punk::ansi::example -help "Display .ans image files in a grid that will fit in console - " - -colwidth -default 82 -help\ - "Width of each column - default of 82 will fit a standard 80wide ansi image - (when framed) - You can specify a narrower width to truncate images on the right side" - -folder -default "${[punk::ansi::Get_ansifolder]}" -help\ - "Base folder for files if relative paths are used. - Defaults to /src/testansi - where projectbase is determined - from the current directory. - " - @values -min 0 -max -1 - files -default {belinda.ans bot.ans flower.ans fish.ans} -multiple true -help\ - "List of filenames - leave empty to display 4 defaults" - } ""] - - proc example {args} { - set argd [punk::args::parse $args withid ::punk::ansi::example] - set colwidth [dict get $argd opts -colwidth] - if {[info commands file] eq ""} { - error "file command unavailable - punk::ansi::example cannot be shown" - } - set ansifolder [file normalize [dict get $argd opts -folder]] - set fnames [dict get $argd values files] - - #assumes fixed column widths e.g 80col images will fit in 82-width frames (common standard for old ansi art) (of arbitrary height) - #todo - review dependency on punk::repo ? - package require textblock - package require punk::repo - package require punk::console - - if {![file exists $ansifolder]} { - puts stderr "Missing folder at $ansifolder" - puts stderr "Ensure ansi test files exist: $fnames" - #error "punk::ansi::example Cannot find example files" - } - set termsize [punk::console:::get_size] - set termcols [dict get $termsize columns] - set margin 4 ;#review - set freewidth [expr {$termcols-$margin}] - if {$freewidth < $colwidth} { - puts stderr "[a+ red bold]punk::ansi::example freewidth: $freewidth < colwidth: $colwidth TRUNCATING IMAGES[a]" - set colwidth $freewidth - } - set per_row [expr {$freewidth / $colwidth}] - - set missingbase [a+ yellow][textblock::block [expr {$colwidth-2}] 23 ?][a] ;#assuming standard frame - subtract 2 for left/right borders - set pics [list] - foreach f $fnames { - if {[file pathtype $f] ne "absolute"} { - set filepath [file normalize $ansifolder/$f] - } else { - set filepath [file normalize $f] - } - if {![file exists $filepath]} { - set p [overtype::left $missingbase "[a+ red bold]\nMissing file\n$f[a]"] - lappend pics [tcl::dict::create filename $f pic $p status missing] - } else { - #set img [join [lines_as_list -line trimline -block trimtail [ansicat $filepath]] \n] - #-line trimline will wreck some images - set img [join [lines_as_list -block trimtail [ansicat $filepath]] \n] - lappend pics [tcl::dict::create filename $f pic $img status ok] - } - } - - - set rowlist [list] ;# { { } { } } - set heightlist [list] ;# { { } { } } - set maxheights [list] ;# { } - set row [list] ;#wip row - set rowh [list] ;#wip row img heights - set i 1 ;#track image index of whole pics list - set rowindex 0 - foreach picinfo $pics { - set subtitle "" - if {[tcl::dict::get $picinfo status] ne "ok"} { - set subtitle [tcl::dict::get $picinfo status] - } - set title [tcl::dict::get $picinfo filename] - set fr [textblock::frame -checkargs 0 -width $colwidth -subtitle $subtitle -title $title [tcl::dict::get $picinfo pic]] - # -- --- --- --- - #we need the max height of a row element to use join_basic instead of join below - # -- --- --- --- - set fr_height [textblock::height $fr] - lappend row $fr - lappend rowh $fr_height - - set rowmax [lindex $maxheights $rowindex] - if {$rowmax eq ""} { - #empty result means no maxheights entry for this row yet - set rowmax $fr_height - lappend maxheights $rowmax - } else { - if {$fr_height > $rowmax} { - set rowmax $fr_height - lset maxheights end $rowmax - } - } - # -- --- --- --- - - if {$i % $per_row == 0} { - lappend rowlist $row - lappend heightlist $rowh - incr rowindex - set row [list] - set rowh [list] - } elseif {$i == [llength $pics]} { - lappend rowlist $row - lappend heightlist $rowh - } - incr i - } - #puts "--> maxheights: $maxheights" - #puts "--> heightlist: $heightlist" - set result "" - set rowindex 0 - set blankline [string repeat " " $colwidth] - foreach imgs $rowlist heights $heightlist { - set maxheight [lindex $maxheights $rowindex] - set adjusted_row [list] - foreach i $imgs h $heights { - if {$h < $maxheight} { - #add blank lines to bottom of shorter images so join_basic can be used. - #textblock::join of ragged-height images would work and remove the need for all the height calculation - #.. but it requires much more processing - append i [string repeat \n$blankline [expr {$maxheight - $h}]] - } - lappend adjusted_row $i - } - #append result [textblock::join_basic -- {*}$adjusted_row] \n - append result [textblock::join_basic_raw {*}$adjusted_row] \n - incr rowindex - } - - - return $result - } - #control strings - #https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf - # - #A control string is a string of bit combinations which may occur in the data stream as a logical entity for - #control purposes. A control string consists of an opening delimiter, a command string or a character string, - #and a terminating delimiter, the STRING TERMINATOR (ST). - #A command string is a sequence of bit combinations in the range 00/08 to 00/13 and 02/00 to 07/14. - #A character string is a sequence of any bit combination, except those representing START OF STRING - #(SOS) or STRING TERMINATOR (ST). - #The interpretation of the command string or the character string is not defined by this Standard, but instead - #requires prior agreement between the sender and the recipient of the data. - #The opening delimiters defined in this Standard are - #a) APPLICATION PROGRAM COMMAND (APC) - #b) DEVICE CONTROL STRING (DCS) - #c) OPERATING SYSTEM COMMAND (OSC) - #d) PRIVACY MESSAGE (PM) - #e) START OF STRING (SOS) - # - - #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. - # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ - #The intent is that it's not rendered to the terminal - so on balance it seems best to strip it out. - #todo - review - printing_length calculations affected by whether terminal honours PMs or not. detect and accomodate. - #review - can terminals handle SGR codes within a PM? - #Wezterm will hide PM,SOS,APC - but not any part following an SGR code - i.e it seems to terminate hiding before the ST (apparently at the ) - proc controlstring_PM {text} { - #dquotes with trailing \\ in string will confuse silly editors - return \x1b^${text}\033\\ - } - proc controlstring_PM8 {text} { - return \x9e${text}\x9c - } - proc controlstring_SOS {text} { - return \x1bX${text}\033\\ - } - proc controlstring_SOS8 {text} { - return \x98${text}\x9c - } - proc controlstring_APC {text} { - return \x1b_${text}\033\\ - } - proc controlstring_APC8 {text} { - return \x9f${text}\x9c - } - #there is also the SGR hide code (8) which has intermittent terminal support - #This doesn't change the output length - so support is tricky to detec. (terminal checksum report?) - - #candidate for zig/c implementation? - proc stripansi2 {text} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters - join [::punk::ansi::ta::split_at_codes $text] "" - } - - - #review - what happens when no terminator? - #todo - map other character sets to unicode equivs? There seems to be little support for other than the DEC special graphics set.. ISO2022 character switching not widely supported - may be best considered deprecated(?) - # convert esc(0 -> esc(B graphics sequences to single char unicode equivalents e.g box drawing set - # esc) ?? - proc convert_g0 {text} { - variable map_special_graphics - - #using not \033 inside to stop greediness - review how does it compare to ".*?" - #variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} - #set re {\033\(0[^\033]*\033\(B} - #set re {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} - #set re2 {\033\(0(.*)\033\(B} ;#capturing - - #puts --$g-- - #box sample - #lqk - #x x - #mqj - #m = boxd_lur - - #don't call detect_g0 in here. Leave for caller. e.g ansistrip uses detect_g0 to decide whether to call this. - - set re_g0_open_or_close {\x1b\(0|\x1b\(B} - set parts [::punk::ansi::ta::_perlish_split $re_g0_open_or_close $text] - set out {} - set g0_on 0 - foreach {other g} $parts { - if {$g0_on} { - #split for non graphics-set codes - set othersplits [punk::ansi::ta::split_codes $other] ;#we don't need single codes here - foreach {inner_plaintext inner_codes} $othersplits { - lappend out [tcl::string::map $map_special_graphics $inner_plaintext] $inner_codes - #Simplifying assumption: no mapping required on any inner_codes - ST codes, titlesets etc don't require/use g0 content - } - } else { - lappend out $other ;#may be a mix of plaintext and other ansi codes - put it all through. - } - #trust our splitting regex has done the work to leave us with only \x1b\(0 or \x1b(B - test last char rather than use punk::ansi::codetype::is_gx_open/is_gx_close - switch -- [tcl::string::index $g end] { - 0 { - set g0_on 1 - } - B { - set g0_on 0 - } - } - } - return [join $out ""] - } - proc convert_g0_wrong {text} { - #Attempting to split on a group is wrong - because there could be other ansi codes while inside a g0 section - #That will either stop us matching - so no conversion - or risk converting parts of the ansi codes - #using not \033 inside to stop greediness - review how does it compare to ".*?" - #variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} - set re {\033\(0[^\033]*\033\(B} - set re2 {\033\(0(.*)\033\(B} ;#capturing - - #box sample - #lqk - #x x - #mqj - #m = boxd_lur - #set map [list l \u250f k \u2513] ;#heavy - set map [list l \u250c q \u2500 k \u2510 x \u2502 m \u2514 j \u2518] ;#light box drawing lines - #todo - map the rest https://vt100.net/docs/vt220-rm/chapter2.html - - set parts [::punk::ansi::ta::_perlish_split $re $text] - set out "" - foreach {pt g} $parts { - append out $pt - if {$g ne ""} { - #puts --$g-- - regexp $re2 $g _match contents - append out [tcl::string::map $map $contents] - } - } - return $out - } - - - - #Wrap text in ansi codes to switch to DEC alternate graphics character set. - #todo vt52 versions - proc g0 {text} { - return \x1b(0$text\x1b(B - } - variable altg_map [dict create\ - hl q\ - vl x\ - tlc l\ - trc k\ - blc m\ - brc j\ - ltj t\ - rtj u\ - ttj w\ - btj v\ - rtj u\ - fwj n\ - ] - proc altg_map {names} { - variable altg_map - set result [list] - foreach nm $names { - if {[dict exists $altg_map $nm]} { - lappend result [dict get $altg_map $nm] - } else { - lappend "" - } - } - return $result - } - - # -------------------------------- - # Taken from term::ansi::code::ctrl - # -------------------------------- - #Note that SYN (\016) seems to put terminals in a state - #where alternate graphics are not processed. - #an ETB (\017) needs to be sent to get alt graphics working again. - #It isn't known what software utilises SYN/ETB within altg sequences - # (presumably to alternate between the charsets within a graphics-on/graphics-off section) - #but as modern emulators seem to react to it, we should handle it. - #REVIEW - this mapping not fully understood - #used by groptim - variable grforw - variable grback - variable _ - - foreach _ { - ! \" # $ % & ' ( ) * + , - . / - 0 1 2 3 4 5 6 7 8 9 : ; < = > - ? @ A B C D E F G H I J K L M - N O P Q R S T U V W X Y Z [ ^ - \\ ] - } { - lappend grforw \016$_ $_\016 - lappend grback $_\017 \017$_ - } - unset _ - # ------------------------------ - #REVIEW - see forward/backward map in term::ansi::code::macros::cd::groptim - what are they for?? - proc groptim {string} { - variable grforw - variable grback - set offon \x1b(B\x1b(0 ;#)) ;#editor highlighting comment - set onoff \x1b(0\x1b(B ;#)) ;#editor highlighting comment - while {![string equal $string [set new [string map [list $offon {} $onoff {}] [string map $grback [string map $grforw $string]]]]]} { - set string $new - } - return $string - } - # -------------------------------- - - proc ansistrip_gx {text} { - #e.g "\033(0" - select VT100 graphics for character set G0 - #e.g "\033(B" - reset - #e.g "\033)0" - select VT100 graphics for character set G1 - #e.g "\033)X" - where X is any char other than 0 to reset ?? - - #return [convert_g0 $text] - return [tcl::string::map [list \x1b(0 "" \x1b(B "" \x1b)0 "" \x1b)X ""] $text] - } - proc stripansi_gx {text} { - return [tcl::string::map [list \x1b(0 "" \x1b(B "" \x1b)0 "" \x1b)X ""] $text] - } - - - #CSI m = SGR (Select Graphic Rendition) -#leave map unindented - used both as a dict and for direct display - variable SGR_setting_map { -reset 0 bold 1 dim 2 italic 3 noitalic 23 -underline 4 doubleunderline 21 nounderline 24 blink 5 fastblink 6 noblink 25 -reverse 7 noreverse 27 hide 8 nohide 28 strike 9 nostrike 29 -normal 22 defaultfg 39 defaultbg 49 overline 53 nooverline 55 -frame 51 framecircle 52 noframe 54 underlinedefault 59 - } - #unprefixed colours are (close to) the ansi-specified colour names (lower-cased and whitespace collapsed, with capitalisation of 1st letter given fg/bg meaning here) -#leave map unindented - used both as a dict and for direct display - variable SGR_colour_map { -black 30 red 31 green 32 yellow 33 blue 34 purple 35 cyan 36 white 37 -Black 40 Red 41 Green 42 Yellow 43 Blue 44 Purple 45 Cyan 46 White 47 -brightblack 90 brightred 91 brightgreen 92 brightyellow 93 brightblue 94 brightpurple 95 brightcyan 96 brightwhite 97 -Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblue 104 Brightpurple 105 Brightcyan 106 Brightwhite 107 - } - variable SGR_map ;#public - part of interface - review - set SGR_map [tcl::dict::merge $SGR_colour_map $SGR_setting_map] - - #we use prefixes e.g web-white and/or x11-white - #Only a leading capital letter will indicate the colour target is background vs lowercase for foreground - #In the map key-lookup context the colour names will be canonically lower case - #We should be case insensitive in the non-prefix part ie after determining fg/bg target from first letter of the prefix - #e.g Web-Lime or Web-lime are ok and are targeting background - #foreground target examples: web-Lime web-LIME web-DarkSalmon web-Darksalmon - - #specified in decimal - but we should also accept hex format directly in a+ function e.g #00FFFF for aqua - variable WEB_colour_map - #use the totitle format as the canonical lookup key - #don't use leading zeros - keep compatible with earlier tcl and avoid octal issue - # -- --- --- - #css 1-2.0 HTML 3.2-4 Basic colours eg web-silver for fg Web-silver for bg - # - variable WEB_colour_map_basic - tcl::dict::set WEB_colour_map_basic white 255-255-255 ;# #FFFFFF - tcl::dict::set WEB_colour_map_basic silver 192-192-192 ;# #C0C0C0 - tcl::dict::set WEB_colour_map_basic gray 128-128-128 ;# #808080 - tcl::dict::set WEB_colour_map_basic black 0-0-0 ;# #000000 - tcl::dict::set WEB_colour_map_basic red 255-0-0 ;# #FF0000 - tcl::dict::set WEB_colour_map_basic maroon 128-0-0 ;# #800000 - tcl::dict::set WEB_colour_map_basic yellow 255-255-0 ;# #FFFF00 - tcl::dict::set WEB_colour_map_basic olive 128-128-0 ;# #808000 - tcl::dict::set WEB_colour_map_basic lime 0-255-0 ;# #00FF00 - tcl::dict::set WEB_colour_map_basic green 0-128-0 ;# #008000 - tcl::dict::set WEB_colour_map_basic aqua 0-255-255 ;# #00FFFF - tcl::dict::set WEB_colour_map_basic teal 0-128-128 ;# #008080 - tcl::dict::set WEB_colour_map_basic blue 0-0-255 ;# #0000FF - tcl::dict::set WEB_colour_map_basic navy 0-0-128 ;# #000080 - tcl::dict::set WEB_colour_map_basic fuchsia 255-0-255 ;# #FF00FF - tcl::dict::set WEB_colour_map_basic purple 128-0-128 ;# #800080 - # -- --- --- - #Pink colours - variable WEB_colour_map_pink - tcl::dict::set WEB_colour_map_pink mediumvioletred 199-21-133 ;# #C71585 - tcl::dict::set WEB_colour_map_pink deeppink 255-20-147 ;# #FF1493 - tcl::dict::set WEB_colour_map_pink palevioletred 219-112-147 ;# #DB7093 - tcl::dict::set WEB_colour_map_pink hotpink 255-105-180 ;# #FF69B4 - tcl::dict::set WEB_colour_map_pink lightpink 255-182-193 ;# #FFB6C1 - tcl::dict::set WEB_colour_map_pink pink 255-192-203 ;# #FFCOCB - # -- --- --- - #Red colours - variable WEB_colour_map_red - tcl::dict::set WEB_colour_map_red darkred 139-0-0 ;# #8B0000 - tcl::dict::set WEB_colour_map_red red 255-0-0 ;# #FF0000 - tcl::dict::set WEB_colour_map_red firebrick 178-34-34 ;# #B22222 - tcl::dict::set WEB_colour_map_red crimson 220-20-60 ;# #DC143C - tcl::dict::set WEB_colour_map_red indianred 205-92-92 ;# #CD5C5C - tcl::dict::set WEB_colour_map_red lightcoral 240-128-128 ;# #F08080 - tcl::dict::set WEB_colour_map_red salmon 250-128-114 ;# #FA8072 - tcl::dict::set WEB_colour_map_red darksalmon 233-150-122 ;# #E9967A - tcl::dict::set WEB_colour_map_red lightsalmon 255-160-122 ;# #FFA07A - # -- --- --- - #Orange colours - variable WEB_colour_map_orange - tcl::dict::set WEB_colour_map_orange orangered 255-69-0 ;# #FF4500 - tcl::dict::set WEB_colour_map_orange tomato 255-99-71 ;# #FF6347 - tcl::dict::set WEB_colour_map_orange darkorange 255-140-0 ;# #FF8C00 - tcl::dict::set WEB_colour_map_orange coral 255-127-80 ;# #FF7F50 - tcl::dict::set WEB_colour_map_orange orange 255-165-0 ;# #FFA500 - # -- --- --- - #Yellow colours - variable WEB_colour_map_yellow - tcl::dict::set WEB_colour_map_yellow darkkhaki 189-183-107 ;# #BDB76B - tcl::dict::set WEB_colour_map_yellow gold 255-215-0 ;# #FFD700 - tcl::dict::set WEB_colour_map_yellow khaki 240-230-140 ;# #F0E68C - tcl::dict::set WEB_colour_map_yellow peachpuff 255-218-185 ;# #FFDAB9 - tcl::dict::set WEB_colour_map_yellow yellow 255-255-0 ;# #FFFF00 - tcl::dict::set WEB_colour_map_yellow palegoldenrod 238-232-170 ;# #EEE8AA - tcl::dict::set WEB_colour_map_yellow moccasin 255-228-181 ;# #FFE4B5 - tcl::dict::set WEB_colour_map_yellow papayawhip 255-239-213 ;# #FFEFD5 - tcl::dict::set WEB_colour_map_yellow lightgoldenrodyeallow 250-250-210 ;# #FAFAD2 - tcl::dict::set WEB_colour_map_yellow lemonchiffon 255-250-205 ;# #FFFACD - tcl::dict::set WEB_colour_map_yellow lightyellow 255-255-224 ;# #FFFFE0 - # -- --- --- - #Brown colours - #maroon as above - variable WEB_colour_map_brown - tcl::dict::set WEB_colour_map_brown brown 165-42-42 ;# #A52A2A - tcl::dict::set WEB_colour_map_brown saddlebrown 139-69-19 ;# #8B4513 - tcl::dict::set WEB_colour_map_brown sienna 160-82-45 ;# #A0522D - tcl::dict::set WEB_colour_map_brown chocolate 210-105-30 ;# #D2691E - tcl::dict::set WEB_colour_map_brown darkgoldenrod 184-134-11 ;# #B8860B - tcl::dict::set WEB_colour_map_brown peru 205-133-63 ;# #CD853F - tcl::dict::set WEB_colour_map_brown rosybrown 188-143-143 ;# #BC8F8F - tcl::dict::set WEB_colour_map_brown goldenrod 218-165-32 ;# #DAA520 - tcl::dict::set WEB_colour_map_brown sandybrown 244-164-96 ;# #F4A460 - tcl::dict::set WEB_colour_map_brown tan 210-180-140 ;# #D2B48C - tcl::dict::set WEB_colour_map_brown burlywood 222-184-135 ;# #DEB887 - tcl::dict::set WEB_colour_map_brown wheat 245-222-179 ;# #F5DEB3 - tcl::dict::set WEB_colour_map_brown navajowhite 255-222-173 ;# #FFDEAD - tcl::dict::set WEB_colour_map_brown bisque 255-228-196 ;# #FFEfC4 - tcl::dict::set WEB_colour_map_brown blanchedalmond 255-228-196 ;# #FFEfC4 - tcl::dict::set WEB_colour_map_brown cornsilk 255-248-220 ;# #FFF8DC - # -- --- --- - #Purple, violet, and magenta colours - variable WEB_colour_map_purple - tcl::dict::set WEB_colour_map_purple indigo 75-0-130 ;# #4B0082 - tcl::dict::set WEB_colour_map_purple purple 128-0-128 ;# #800080 - tcl::dict::set WEB_colour_map_purple darkmagenta 139-0-139 ;# #8B008B - tcl::dict::set WEB_colour_map_purple darkviolet 148-0-211 ;# #9400D3 - tcl::dict::set WEB_colour_map_purple darkslateblue 72-61-139 ;# #9400D3 - tcl::dict::set WEB_colour_map_purple blueviolet 138-43-226 ;# #8A2BE2 - tcl::dict::set WEB_colour_map_purple darkorchid 153-50-204 ;# #9932CC - tcl::dict::set WEB_colour_map_purple fuchsia 255-0-255 ;# #FF00FF - tcl::dict::set WEB_colour_map_purple magenta 255-0-255 ;# #FF00FF - same as fuchsia - tcl::dict::set WEB_colour_map_purple slateblue 106-90-205 ;# #6A5ACD - tcl::dict::set WEB_colour_map_purple mediumslateblue 123-104-238 ;# #7B68EE - tcl::dict::set WEB_colour_map_purple mediumorchid 186-85-211 ;# #BA5503 - tcl::dict::set WEB_colour_map_purple mediumpurple 147-112-219 ;# #9370DB - tcl::dict::set WEB_colour_map_purple orchid 218-112-214 ;# #DA70D6 - tcl::dict::set WEB_colour_map_purple violet 238-130-238 ;# #EE82EE - tcl::dict::set WEB_colour_map_purple plum 221-160-221 ;# #DDA0DD - tcl::dict::set WEB_colour_map_purple thistle 216-191-216 ;# #D88FD8 - tcl::dict::set WEB_colour_map_purple lavender 230-230-250 ;# #E6E6FA - # -- --- --- - #Blue colours - variable WEB_colour_map_blue - tcl::dict::set WEB_colour_map_blue midnightblue 25-25-112 ;# #191970 - tcl::dict::set WEB_colour_map_blue navy 0-0-128 ;# #000080 - tcl::dict::set WEB_colour_map_blue darkblue 0-0-139 ;# #00008B - tcl::dict::set WEB_colour_map_blue mediumblue 0-0-205 ;# #0000CD - tcl::dict::set WEB_colour_map_blue blue 0-0-255 ;# #0000FF - tcl::dict::set WEB_colour_map_blue royalblue 65-105-225 ;# #4169E1 - tcl::dict::set WEB_colour_map_blue steelblue 70-130-180 ;# #4682B4 - tcl::dict::set WEB_colour_map_blue dodgerblue 30-144-255 ;# #1E90FF - tcl::dict::set WEB_colour_map_blue deepskyblue 0-191-255 ;# #00BFFF - tcl::dict::set WEB_colour_map_blue cornflowerblue 100-149-237 ;# #6495ED - tcl::dict::set WEB_colour_map_blue skyblue 135-206-235 ;# #87CEEB - tcl::dict::set WEB_colour_map_blue lightskyblue 135-206-250 ;# #87CEFA - tcl::dict::set WEB_colour_map_blue lightsteelblue 176-196-222 ;# #B0C4DE - tcl::dict::set WEB_colour_map_blue lightblue 173-216-230 ;# #ADD8E6 - tcl::dict::set WEB_colour_map_blue powderblue 176-224-230 ;# #B0E0E6 - # -- --- --- - #Cyan colours - #teal as above - variable WEB_colour_map_cyan - tcl::dict::set WEB_colour_map_cyan darkcyan 0-139-139 ;# #008B8B - tcl::dict::set WEB_colour_map_cyan lightseagreen 32-178-170 ;# #20B2AA - tcl::dict::set WEB_colour_map_cyan cadetblue 95-158-160 ;# #5F9EA0 - tcl::dict::set WEB_colour_map_cyan darkturquoise 0-206-209 ;# #00CED1 - tcl::dict::set WEB_colour_map_cyan mediumturquoise 72-209-204 ;# #48D1CC - tcl::dict::set WEB_colour_map_cyan turquoise 64-224-208 ;# #40E0D0 - tcl::dict::set WEB_colour_map_cyan aqua 0-255-255 ;# #00FFFF - tcl::dict::set WEB_colour_map_cyan cyan 0-255-255 ;# #00FFFF - same as aqua - tcl::dict::set WEB_colour_map_cyan aquamarine 127-255-212 ;# #7FFFD4 - tcl::dict::set WEB_colour_map_cyan paleturquoise 175-238-238 ;# #AFEEEE - tcl::dict::set WEB_colour_map_cyan lightcyan 224-255-255 ;# #E0FFFF - # -- --- --- - #Green colours - variable WEB_colour_map_green - tcl::dict::set WEB_colour_map_green darkgreen 0-100-0 ;# #006400 - tcl::dict::set WEB_colour_map_green green 0-128-0 ;# #008000 - tcl::dict::set WEB_colour_map_green darkolivegreen 85-107-47 ;# #55682F - tcl::dict::set WEB_colour_map_green forestgreen 34-139-34 ;# #228B22 - tcl::dict::set WEB_colour_map_green seagreen 46-139-87 ;# #2E8B57 - tcl::dict::set WEB_colour_map_green olive 128-128-0 ;# #808000 - tcl::dict::set WEB_colour_map_green olivedrab 107-142-35 ;# #6B8E23 - tcl::dict::set WEB_colour_map_green mediumseagreen 60-179-113 ;# #3CB371 - tcl::dict::set WEB_colour_map_green limegreen 50-205-50 ;# #32CD32 - tcl::dict::set WEB_colour_map_green lime 0-255-0 ;# #00FF00 - tcl::dict::set WEB_colour_map_green springgreen 0-255-127 ;# #00FF7F - tcl::dict::set WEB_colour_map_green mediumspringgreen 0-250-154 ;# #00FA9A - tcl::dict::set WEB_colour_map_green darkseagreen 143-188-143 ;# #8FBC8F - tcl::dict::set WEB_colour_map_green mediumaquamarine 102-205-170 ;# #66CDAA - tcl::dict::set WEB_colour_map_green yellowgreen 154-205-50 ;# #9ACD32 - tcl::dict::set WEB_colour_map_green lawngreen 124-252-0 ;# #7CFC00 - tcl::dict::set WEB_colour_map_green chartreuse 127-255-0 ;# #7FFF00 - tcl::dict::set WEB_colour_map_green lightgreen 144-238-144 ;# #90EE90 - tcl::dict::set WEB_colour_map_green greenyellow 173-255-47 ;# #ADFF2F - tcl::dict::set WEB_colour_map_green palegreen 152-251-152 ;# #98FB98 - # -- --- --- - #White colours - variable WEB_colour_map_white - tcl::dict::set WEB_colour_map_white mistyrose 255-228-225 ;# #FFE4E1 - tcl::dict::set WEB_colour_map_white antiquewhite 250-235-215 ;# #FAEBD7 - tcl::dict::set WEB_colour_map_white linen 250-240-230 ;# #FAF0E6 - tcl::dict::set WEB_colour_map_white beige 245-245-220 ;# #F5F5DC - tcl::dict::set WEB_colour_map_white whitesmoke 245-245-245 ;# #F5F5F5 - tcl::dict::set WEB_colour_map_white lavenderblush 255-240-245 ;# #FFF0F5 - tcl::dict::set WEB_colour_map_white oldlace 253-245-230 ;# #FDF5E6 - tcl::dict::set WEB_colour_map_white aliceblue 240-248-255 ;# #F0F8FF - tcl::dict::set WEB_colour_map_white seashell 255-245-238 ;# #FFF5EE - tcl::dict::set WEB_colour_map_white ghostwhite 248-248-255 ;# #F8F8FF - tcl::dict::set WEB_colour_map_white honeydew 240-255-240 ;# #F0FFF0 - tcl::dict::set WEB_colour_map_white floralwhite 255-250-240 ;# #FFFAF0 - tcl::dict::set WEB_colour_map_white azure 240-255-255 ;# #F0FFFF - tcl::dict::set WEB_colour_map_white mintcream 245-255-250 ;# #F5FFFA - tcl::dict::set WEB_colour_map_white snow 255-250-250 ;# #FFFAFA - tcl::dict::set WEB_colour_map_white ivory 255-255-240 ;# #FFFFF0 - tcl::dict::set WEB_colour_map_white white 255-255-255 ;# #FFFFFF - # -- --- --- - #Gray and black colours - variable WEB_colour_map_gray - tcl::dict::set WEB_colour_map_gray black 0-0-0 ;# #000000 - tcl::dict::set WEB_colour_map_gray darkslategray 47-79-79 ;# #2F4F4F - tcl::dict::set WEB_colour_map_gray dimgray 105-105-105 ;# #696969 - tcl::dict::set WEB_colour_map_gray slategray 112-128-144 ;# #708090 - tcl::dict::set WEB_colour_map_gray gray 128-128-128 ;# #808080 - tcl::dict::set WEB_colour_map_gray lightslategray 119-136-153 ;# #778899 - tcl::dict::set WEB_colour_map_gray darkgray 169-169-169 ;# #A9A9A9 - tcl::dict::set WEB_colour_map_gray silver 192-192-192 ;# #C0C0C0 - tcl::dict::set WEB_colour_map_gray lightgray 211-211-211 ;# #D3D3D3 - tcl::dict::set WEB_colour_map_gray gainsboro 220-220-220 ;# #DCDCDC - - set WEB_colour_map [tcl::dict::merge\ - $WEB_colour_map_basic\ - $WEB_colour_map_pink\ - $WEB_colour_map_red\ - $WEB_colour_map_orange\ - $WEB_colour_map_yellow\ - $WEB_colour_map_brown\ - $WEB_colour_map_purple\ - $WEB_colour_map_blue\ - $WEB_colour_map_cyan\ - $WEB_colour_map_green\ - $WEB_colour_map_white\ - $WEB_colour_map_gray\ - ] - - #we should be able to use WEB_colour_map as a base and override only the conflicts for X11 colours ? Review - check if this is true - variable X11_colour_map_diff ;#maintain the difference as a separate dict so we can display in a? x11 - tcl::dict::set X11_colour_map_diff gray 190-190-190 ;# #BEBEBE - tcl::dict::set X11_colour_map_diff green 0-255-0 ;# #00FF00 - tcl::dict::set X11_colour_map_diff maroon 176-48-96 ;# #B03060 - tcl::dict::set X11_colour_map_diff purple 160-32-240 ;# #A020F0 - - variable X11_colour_map - set X11_colour_map [tcl::dict::merge $WEB_colour_map $X11_colour_map_diff] - - - - - - - #Xterm colour names (256 colours) - #lists on web have duplicate names - #these have been renamed here in a systematic way: - #They are suffixed with a dash and a letter e.g second deepskyblue4 -> deepskyblue4-b, third deepskyblue4 -> deepskyblue4-c - #presumably the xterm colour names are not widely used or are used for reverse lookup from rgb to get an approximate name in the case of dupes? - #Review! - #keep duplicate names in the list and map them when building the dict. - - #This is an in depth analysis of the xterm colour set which gives names(*) to all of the 256 colours and describes possible indexing by Hue,Luminance,Saturation - #https://www.wowsignal.io/articles/xterm256 - # *The names are wildly-imaginative, often unintuitively so, and multiple (5?) given for each colour - so they are unlikely to be of practical use or any sort of standard. - #e.g who is to know that 'Rabbit Paws', 'Forbidden Thrill' and 'Tarsier' refer to a particular shade of pinky-red? (code 95) - #Perhaps it's an indication that colour naming once we get to 256 colours or more is a fool's errand anyway. - #The xterm names are boringly unimaginative - and also have some oddities such as: - # DarkSlateGray1 which looks much more like cyan.. - # The greyxx names are spelt with an e - but the darkslategrayX variants use an a. Perhaps that's because they are more cyan than grey and the a is a hint? - #(more likely just a mix of UK vs US spelling) - # there is no gold or gold2 - but there is gold1 and gold3 - #but in general the names bear some resemblance to the colours and are at least somewhat intuitive. - - set xterm_names [list\ - black\ - maroon\ - green\ - olive\ - navy\ - purple\ - teal\ - silver\ - grey\ - red\ - lime\ - yellow\ - blue\ - fuchsia\ - aqua\ - white\ - grey0\ - navyblue\ - darkblue\ - blue3\ - blue3\ - blue1\ - darkgreen\ - deepskyblue4\ - deepskyblue4\ - deepskyblue4\ - dodgerblue3\ - dodgerblue2\ - green4\ - springgreen4\ - turquoise4\ - deepskyblue3\ - deepskyblue3\ - dodgerblue1\ - green3\ - springgreen3\ - darkcyan\ - lightseagreen\ - deepskyblue2\ - deepskyblue1\ - green3\ - springgreen3\ - springgreen2\ - cyan3\ - darkturquoise\ - turquoise2\ - green1\ - springgreen2\ - springgreen1\ - mediumspringgreen\ - cyan2\ - cyan1\ - darkred\ - deeppink4\ - purple4\ - purple4\ - purple3\ - blueviolet\ - orange4\ - grey37\ - mediumpurple4\ - slateblue3\ - slateblue3\ - royalblue1\ - chartreuse4\ - darkseagreen4\ - paleturquoise4\ - steelblue\ - steelblue3\ - cornflowerblue\ - chartreuse3\ - darkseagreen4\ - cadetblue\ - cadetblue\ - skyblue3\ - steelblue1\ - chartreuse3\ - palegreen3\ - seagreen3\ - aquamarine3\ - mediumturquoise\ - steelblue1\ - chartreuse2\ - seagreen2\ - seagreen1\ - seagreen1\ - aquamarine1\ - darkslategray2\ - darkred\ - deeppink4\ - darkmagenta\ - darkmagenta\ - darkviolet\ - purple\ - orange4\ - lightpink4\ - plum4\ - mediumpurple3\ - mediumpurple3\ - slateblue1\ - yellow4\ - wheat4\ - grey53\ - lightslategrey\ - mediumpurple\ - lightslateblue\ - yellow4\ - darkolivegreen3\ - darkseagreen\ - lightskyblue3\ - lightskyblue3\ - skyblue2\ - chartreuse2\ - darkolivegreen3\ - palegreen3\ - darkseagreen3\ - darkslategray3\ - skyblue1\ - chartreuse1\ - lightgreen\ - lightgreen\ - palegreen1\ - aquamarine1\ - darkslategray1\ - red3\ - deeppink4\ - mediumvioletred\ - magenta3\ - darkviolet\ - purple\ - darkorange3\ - indianred\ - hotpink3\ - mediumorchid3\ - mediumorchid\ - mediumpurple2\ - darkgoldenrod\ - lightsalmon3\ - rosybrown\ - grey63\ - mediumpurple2\ - mediumpurple1\ - gold3\ - darkkhaki\ - navajowhite\ - grey69\ - lightsteelblue3\ - lightsteelblue\ - yellow3\ - darkolivegreen3\ - darkseagreen3\ - darkseagreen2\ - lightcyan3\ - lightskyblue1\ - greenyellow\ - darkolivegreen2\ - palegreen1\ - darkseagreen2\ - darkseagreen1\ - paleturquoise1\ - red3\ - deeppink3\ - deeppink3\ - magenta3\ - magenta3\ - magenta2\ - darkorange3\ - indianred\ - hotpink3\ - hotpink2\ - orchid\ - mediumorchid1\ - orange3\ - lightsalmon3\ - lightpink3\ - pink3\ - plum3\ - violet\ - gold3\ - lightgoldenrod3\ - tan\ - mistyrose3\ - thistle3\ - plum2\ - yellow3\ - khaki3\ - lightgoldenrod2\ - lightyellow3\ - grey84\ - lightsteelblue1\ - yellow2\ - darkolivegreen1\ - darkolivegreen1\ - darkseagreen1\ - honeydew2\ - lightcyan1\ - red1\ - deeppink2\ - deeppink1\ - deeppink1\ - magenta2\ - magenta1\ - orangered1\ - indianred1\ - indianred1\ - hotpink\ - hotpink\ - mediumorchid1\ - darkorange\ - salmon1\ - lightcoral\ - palevioletred1\ - orchid2\ - orchid1\ - orange1\ - sandybrown\ - lightsalmon1\ - lightpink1\ - pink1\ - plum1\ - gold1\ - lightgoldenrod2\ - lightgoldenrod2\ - navajowhite1\ - mistyrose1\ - thistle1\ - yellow1\ - lightgoldenrod1\ - khaki1\ - wheat1\ - cornsilk1\ - grey100\ - grey3\ - grey7\ - grey11\ - grey11\ - grey15\ - grey19\ - grey23\ - grey27\ - grey30\ - grey35\ - grey39\ - grey42\ - grey46\ - grey50\ - grey54\ - grey58\ - grey62\ - grey66\ - grey70\ - grey74\ - grey78\ - grey82\ - grey85\ - grey89\ - grey93\ - ] - variable TERM_colour_map - set TERM_colour_map [tcl::dict::create] - variable TERM_colour_map_reverse - set TERM_colour_map_reverse [tcl::dict::create] - set cidx 0 - foreach cname $xterm_names { - if {![tcl::dict::exists $TERM_colour_map $cname]} { - tcl::dict::set TERM_colour_map $cname $cidx - tcl::dict::set TERM_colour_map_reverse $cidx $cname - } else { - set did_rename 0 - #start suffixes at '-b'. The base name could be considered the '-a' version - but we don't create it. - foreach {suffix} {b c} { - if {![tcl::dict::exists $TERM_colour_map $cname-$suffix]} { - tcl::dict::set TERM_colour_map $cname-$suffix $cidx - tcl::dict::set TERM_colour_map_reverse $cidx $cname-$suffix - set did_rename 1 - break - } - } - if {!$did_rename} { - error "Not enough suffixes for duplicate names in xterm colour list. Add more suffixes or review list" - } - } - incr cidx - } - - - - - #colour_hex2ansidec - #conversion of hex to format directly pluggable to ansi rgb format (colon separated e.g for foreground we need "38;2;$r;$g;$b" so we return $r;$g;$b) - #we want to support arbitrary rgb values specified in hex - so a table of 16M+ is probably not a great idea - #hex zero-padded - canonically upper case but mixed or lower accepted - #dict for {k v} $WEB_colour_map { - # set dectriple [split $v -] - # set webhex [::join [format %02X%02X%02X {*}$dectriple] ;# e.g 808080, FFFFFF, 000000 - # tcl::dict::set HEX_colour_map $webhex [join $dectriple {;}] - #} - proc colour_hex2ansidec {hex6} { - return [join [::scan $hex6 %2X%2X%2X] {;}] - } - - #convert between hex and decimal as used in the a+ function - # eg dec-dec-dec <-> #HHHHHH - #allow hex to be specified with or without leading # - proc colour_hex2dec {hex6} { - set hex6 [tcl::string::map {# ""} $hex6] - return [join [::scan $hex6 %2X%2X%2X] {-}] - } - proc colour_dec2hex {decimalcolourstring} { - set dec [tcl::string::map [list {;} - , -] $decimalcolourstring] - set declist [split $dec -] - set hex #[format %02X%02X%02X {*}$declist] - } - - proc get_sgr_map {} { - variable SGR_map - return $SGR_map - } - - proc colourmap1 {args} { - set opts {-bg Web-white -forcecolour 0} - foreach {k v} $args { - switch -- $k { - -bg - -forcecolour { - tcl::dict::set opts $k $v - } - default { - error "colourmap1 unrecognised option $k. Known-options: [tcl::dict::keys $opts]" - } - } - } - if {[tcl::dict::get $opts -forcecolour]} { - set fc "forcecolour" - } else { - set fc "" - } - set bgname [tcl::dict::get $opts -bg] - - package require textblock - set bg [textblock::block 33 3 "[a+ {*}$fc $bgname] [a]"] - set colourmap "" - set RST [a] - for {set i 0} {$i <= 7} {incr i} { - #append colourmap "_[a+ white bold 48\;5\;$i] $i [a]" - append colourmap "_[a+ {*}$fc white bold Term-$i] $i $RST" - } - set map1 [overtype::left -transparent _ $bg "\n$colourmap"] - return $map1 - } - proc colourmap2 {args} { - set defaults {-forcecolour 0 -bg Web-white} - set opts [tcl::dict::merge $defaults $args] - set fc "" - if {[tcl::dict::get $opts -forcecolour]} { - set fc "forcecolour" - } - set bgname [tcl::dict::get $opts -bg] - - package require textblock - set bg [textblock::block 39 3 "[a+ {*}$fc $bgname] [a]"] - set colourmap "" - set RST [a] - for {set i 8} {$i <= 15} {incr i} { - if {$i == 8} { - set fg "bold white" - } else { - set fg "black normal" ;#black normal is often blacker than black bold - which can display as a grey - } - append colourmap "_[a+ {*}$fc {*}$fg 48\;5\;$i] $i $RST" - } - set map2 [overtype::left -transparent _ $bg "\n$colourmap"] - return $map2 - } - proc colourtable_216 {args} { - set defaults {-forcecolour 0} - set opts [tcl::dict::merge $defaults $args] - set fc "" - if {[tcl::dict::get $opts -forcecolour]} { - set fc "forcecolour" - } - package require textblock - set clist [list] - set fg "black" - for {set i 16} {$i <=231} {incr i} { - if {$i % 18 == 16} { - if {$fg eq "black"} { - set fg "bold white" - } else { - set fg "black" - } - } - lappend clist "[a+ {*}$fc {*}$fg Term-$i][format %3s $i]" - } - - set t [textblock::list_as_table -columns 36 -return tableobject $clist] - $t configure -show_hseps 0 - #return [$t print] - return $t - } - - #1st 16 colours of 256 - match SGR colours - proc colourblock_16 {args} { - set defaults {-forcecolour 0} - set opts [tcl::dict::merge $defaults $args] - set fc "" - if {[tcl::dict::get $opts -forcecolour]} { - set fc "forcecolour" - } - set out "" - set fg "bold white" - for {set i 0} {$i <= 15} {incr i} { - #8 is black - so start black fg at 9 - if {$i > 8} { - set fg "web-black" - } - append out "[a+ {*}$fc {*}$fg Term-$i][format %3s $i] " - } - return $out[a] - } - proc colourtable_16_names {args} { - set defaults {-forcecolour 0} - set opts [tcl::dict::merge $defaults $args] - set fc "" - if {[tcl::dict::get $opts -forcecolour]} { - set fc "forcecolour" - } - variable TERM_colour_map_reverse - set rows [list] - set row [list] - set fg "web-white" - set t [textblock::class::table new] - $t configure -show_seps 0 -show_edge 0 - for {set i 0} {$i <=15} {incr i} { - set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-$i etc instead of term-$name? - if {[llength $row]== 8} { - lappend rows $row - set row [list] - } - if {$i == 8} { - set fg "web-white" - } elseif {$i > 6} { - set fg "web-black" - } - #lappend row "[a+ {*}$fc {*}$fg Term-$cname][format %3s $i] $cname " - lappend row "[a+ {*}$fc {*}$fg Term-$i][format %3s $i] $cname " - } - lappend rows $row - foreach r $rows { - $t add_row $r - } - append out [$t print] - $t destroy - append out [a] - return [tcl::string::trimleft $out \n] - - } - #216 colours of 256 - proc colourblock_216 {args} { - set defaults {-forcecolour 0} - set opts [tcl::dict::merge $defaults $args] - set fc "" - if {[tcl::dict::get $opts -forcecolour]} { - set fc "forcecolour" - } - set out "" - set fg "web-black" - for {set i 16} {$i <=231} {incr i} { - if {$i % 18 == 16} { - if {$fg eq "web-black"} { - set fg "web-white" - } else { - set fg "web-black" - } - set br "\n" - } else { - set br "" - } - append out "$br[a+ {*}$fc {*}$fg Term-$i][format %3s $i] " - } - append out [a] - return [tcl::string::trimleft $out \n] - } - - #x6 is reasonable from a width (124 screen cols) and colour viewing perspective - proc colourtable_216_names {args} { - set defaults {-forcecolour 0 -columns 6} - set opts [tcl::dict::merge $defaults $args] - set fc "" - if {[tcl::dict::get $opts -forcecolour]} { - set fc "forcecolour" - } - set cols [tcl::dict::get $opts -columns] - - set out "" - #use the reverse lookup dict - the original xterm_names list has duplicates - we want the disambiguated (potentially suffixed) names - variable TERM_colour_map_reverse - set rows [list] - set row [list] - set fg "web-black" - set t [textblock::class::table new] - $t configure -show_seps 0 -show_edge 0 - for {set i 16} {$i <=231} {incr i} { - set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-cname etc instead of term-$i - may as well let a+ cache the call by name as the preferred? option - if {[llength $row]== $cols} { - lappend rows $row - set row [list] - } - if {$i % 18 == 16} { - if {$fg eq "web-black"} { - set fg "web-white" - } else { - set fg "web-black" - } - } - lappend row "[a+ {*}$fc {*}$fg Term-$cname][format %3s $i] $cname " - } - lappend rows $row - foreach r $rows { - $t add_row $r - } - append out [$t print] - $t destroy - append out [a] - return [tcl::string::trimleft $out \n] - } - proc colourtable_term_pastel {args} { - set defaults {-forcecolour 0} - set opts [tcl::dict::merge $defaults $args] - set fc "" - if {[tcl::dict::get $opts -forcecolour]} { - set fc "forcecolour" - } - set out "" - set rows [list] - #see https://www.hackitu.de/termcolor256/ - lappend rows {59 95 131 167 174 181 188} - lappend rows {59 95 131 173 180 187 188} - lappend rows {59 95 137 179 186 187 188} - lappend rows {59 101 143 185 186 187 188} - lappend rows {59 65 107 149 186 187 188} - lappend rows {59 65 71 113 150 187 188} - lappend rows {59 65 71 77 114 151 188} - lappend rows {59 65 71 78 115 152 188} - lappend rows {59 65 72 79 116 152 188} - lappend rows {59 66 73 80 116 152 188} - lappend rows {59 60 67 74 116 152 188} - lappend rows {59 60 61 68 110 152 188} - lappend rows {59 60 61 62 104 146 188} - lappend rows {59 60 61 98 140 182 188} - lappend rows {59 60 97 134 176 182 188} - lappend rows {59 96 133 170 176 182 188} - lappend rows {59 95 132 169 176 182 188} - lappend rows {59 95 131 168 175 182 188} - - set t [textblock::class::table new] - $t configure -show_seps 0 -show_edge 0 - set fg "web-black" - foreach r $rows { - set rowcells [list] - foreach cnum $r { - lappend rowcells "[a+ {*}$fc $fg Term-$cnum][format %3s $cnum] " - } - $t add_row $rowcells - } - append out [$t print] - $t destroy - set pastel8 [list 102 138 144 108 109 103 139 145] - set p8 "" - foreach cnum $pastel8 { - append p8 "[a+ {*}$fc $fg Term-$cnum][format %3s $cnum] " - } - #append p8 [a]\n - #append out \n $p8 - - append p8 [a] - append out \n $p8 - - return $out - } - proc colourtable_term_rainbow {args} { - set defaults {-forcecolour 0} - set opts [tcl::dict::merge $defaults $args] - set fc "" - if {[tcl::dict::get $opts -forcecolour]} { - set fc "forcecolour" - } - set out "" - set rows [list] - set fgwhite [list 16 52 88 124 160 22 17 18 19 20 21 57 56 93 55 92 54 91 53 90 89 126 88 125 124 160] - #see https://www.hackitu.de/termcolor256/ - lappend rows {16 52 88 124 160 196 203 210 217 224 231} - lappend rows {16 52 88 124 160 202 209 216 223 230 231} - lappend rows {16 52 88 124 166 208 215 222 229 230 231} - lappend rows {16 52 88 130 172 214 221 228 229 230 231} - lappend rows {16 52 94 136 178 220 227 227 228 230 231} - - lappend rows {16 58 100 142 184 226 227 228 228 230 231} - - lappend rows {16 22 64 106 148 190 227 228 229 230 231} - lappend rows {16 22 28 70 112 154 191 228 229 230 231} - lappend rows {16 22 28 34 76 118 155 192 229 230 231} - lappend rows {16 22 28 34 40 82 119 156 193 230 231} - lappend rows {16 22 28 34 40 46 83 120 157 194 231} - lappend rows {16 22 28 34 40 47 84 121 158 195 231} - lappend rows {16 22 28 34 41 48 85 122 158 195 231} - lappend rows {16 22 28 35 42 49 86 123 159 195 231} - lappend rows {16 22 29 36 43 50 87 123 159 195 231} - - lappend rows {16 23 30 37 44 51 87 123 159 195 231} - - lappend rows {16 17 24 31 38 45 87 123 159 195 231} - lappend rows {16 17 18 25 32 39 81 123 159 195 231} - lappend rows {16 17 18 19 26 33 75 117 159 195 231} - lappend rows {16 17 18 19 20 27 69 111 153 195 231} - lappend rows {16 17 18 19 20 21 63 105 147 189 231} - lappend rows {16 17 18 19 20 57 99 141 183 225 231} - lappend rows {16 17 18 19 56 93 135 177 219 225 231} - lappend rows {16 17 18 55 92 129 171 213 219 225 231} - lappend rows {16 17 54 91 128 165 207 213 219 225 231} - - lappend rows {16 53 90 127 164 201 207 213 219 225 231} - - lappend rows {16 52 89 126 163 200 207 213 219 225 231} - lappend rows {16 52 88 125 162 199 206 213 219 225 231} - lappend rows {16 52 88 124 161 198 205 212 219 225 231} - lappend rows {16 52 88 124 160 197 204 211 218 225 231} - - - set t [textblock::class::table new] - $t configure -show_seps 0 -show_edge 0 - foreach r $rows { - set rowcells [list] - foreach cnum $r { - if {$cnum in $fgwhite} { - set fg "web-white" - } else { - set fg "web-black" - } - lappend rowcells "[a+ {*}$fc $fg Term-$cnum][format %3s $cnum] " - } - $t add_row $rowcells - } - append out [$t print] - $t destroy - return $out - } - #24 greys of 256 - proc colourblock_24 {args} { - set defaults {-forcecolour 0} - set opts [tcl::dict::merge $defaults $args] - set fc "" - if {[tcl::dict::get $opts -forcecolour]} { - set fc "forcecolour" - } - - set out "" - set fg "bold white" - for {set i 232} {$i <= 255} {incr i} { - if {$i > 243} { - set fg "web-black" - } - append out "[a+ {*}$fc {*}$fg Term-$i][format %3s $i] " - } - return $out[a] - - } - proc colourtable_24_names {args} { - set defaults {-forcecolour 0} - set opts [tcl::dict::merge $defaults $args] - set fc "" - if {[tcl::dict::get $opts -forcecolour]} { - set fc "forcecolour" - } - - variable TERM_colour_map_reverse - set rows [list] - set row [list] - set fg "web-white" - set t [textblock::class::table new] - $t configure -show_hseps 0 -show_edge 0 - for {set i 232} {$i <=255} {incr i} { - set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-cname etc instead of term-$i - may as well let a+ cache the call by name as the preferred? option - if {[llength $row]== 8} { - lappend rows $row - set row [list] - } - if {$i > 243} { - set fg "web-black" - } - lappend row "[a+ {*}$fc {*}$fg Term-$cname][format %3s $i] $cname " - } - lappend rows $row - foreach r $rows { - $t add_row $r - } - append out [$t print] - $t destroy - append out [a] - return [tcl::string::trimleft $out \n] - - } - - if {[catch {package require punk::ansi::colourmap} errM]} { - puts stderr "punk::ansi FAILED to load punk::ansi::colourmap\n$errM" - } - if {[info exists ::punk::ansi::colourmap::TK_colour_map]} { - upvar ::punk::ansi::colourmap::TK_colour_map TK_colour_map - upvar ::punk::ansi::colourmap::TK_colour_map_lookup TK_colour_map_lookup - } else { - puts stderr "Failed to find TK_colour_map - punk::ansi::colourmap package not loaded?" - variable TK_colour_map {} - variable TK_colour_map_lookup {} - } - - #order-preserving - proc lunique {list} { - set new {} - foreach item $list { - if {$item ni $new} { - lappend new $item - } - } - return $new - } - - proc colourtable_tk {args} { - set opts {-forcecolour 0 -groups * -merged 0 -globs *} - foreach {k v} $args { - switch -- $k { - -groups - -merged - -forcecolour - -globs { - tcl::dict::set opts $k $v - } - default { - error "colourtable_tk unrecognised option '$k'. Known-options: [tcl::dict::keys $opts]" - } - } - } - set fc "" - if {[tcl::dict::get $opts -forcecolour]} { - set fc "forcecolour" - } - - #not implemented - todo? Tk - set groups [tcl::dict::get $opts -groups] - - set do_merge [tcl::dict::get $opts -merged] - set globs [tcl::dict::get $opts -globs] - - - - set blocklist [list] ;#vertical blocks consisting of blockrows - set blockrow [list] - set height 50 ;#number of lines (excluding header) vertically in a blockrow - set columns 5 ;#number of columns in a blockrow - variable TK_colour_map ;#use the version without lowercased additions - this gives the display names with casing as shown in Tk colour man page. - if {!$do_merge} { - set map $TK_colour_map - if {$globs eq "*"} { - set keys [dict keys $TK_colour_map] - } else { - set keys [list] - set mapkeys [dict keys $TK_colour_map] - foreach g $globs { - #lappend keys {*}[dict keys $map $g] - #need case insensitive globs for convenience. - lappend keys {*}[lsearch -all -glob -inline -nocase $mapkeys $g] - } - set keys [lunique $keys] - } - } else { - #todo - make glob fully search when do_merge - #needs to get keys from all names - but then map to keys that have dependent names - upvar ::punk::ansi::colourmap::TK_colour_map_merge map - upvar ::punk::ansi::colourmap::TK_colour_map_reverse reversemap - if {$globs eq "*"} { - set keys [dict keys $map] - } else { - set keys [list] - set allkeys [dict keys $TK_colour_map] - - foreach g $globs { - set matchedkeys [lsearch -all -glob -inline -nocase $allkeys $g] - foreach m $matchedkeys { - if {![dict exists $map $m]} { - #not a parent in a merge - set rgb [dict get $TK_colour_map $m] - set names [dict get $reversemap $rgb] - #first name is the one that is in the merge map - lappend keys [lindex $names 0] - } else { - lappend keys $m - } - } - } - set keys [lunique $keys] - } - } - set overheight 0 - - - set t "" - set start 0 - set colidx -1 - set i -1 - foreach cname $keys { - incr i - set data [dict get $map $cname] - if {$overheight || $i % $height == 0} { - set overheight 0 - incr colidx - if {$t ne ""} { - $t configure -frametype {} - $t configure_column 0 -headers [list "TK colours $start - $i"] - $t configure_column 0 -header_colspans [list any] - $t configure -ansibase_header [a+ {*}$fc web-black Web-white] - lappend blockrow [$t print] " " - $t destroy - if {$colidx % $columns == 0} { - lappend blocklist $blockrow - set blockrow [list] - } - } - set start $i - set t [textblock::class::table new] - $t configure -show_edge 0 -show_seps 0 -show_header 1 -minwidth 42 - } - if {!$do_merge} { - set cdec $data - $t add_row [list $cname " [colour_dec2hex $cdec] " $cdec] - } else { - set cdec [dict get $data colour] - set othernames [dict get $data names] - set ndisplay [join [list $cname {*}$othernames] \n] - $t add_row [list $ndisplay " [colour_dec2hex $cdec] " $cdec] - set overheight 0 - foreach n $othernames { - incr i - if {$i % $height == 0} { - set overheight 1 - } - } - } - set fg "rgb-$cdec-contrasting" - $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Rgb-$cdec] - } - - if {$t ne ""} { - $t configure -frametype {} - $t configure_column 0 -headers [list "TK colours $start - $i"] - $t configure_column 0 -header_colspans [list any] - $t configure -ansibase_header [a+ {*}$fc web-black Web-white] - lappend blockrow [$t print] " " - lappend blocklist $blockrow - $t destroy - } - - set result "" - foreach blockrow $blocklist { - append result [textblock::join -- {*}$blockrow] \n - } - - return $result - } - - #set WEB_colour_map [tcl::dict::merge\ - # $WEB_colour_map_basic\ - # $WEB_colour_map_pink\ - # $WEB_colour_map_red\ - # $WEB_colour_map_orange\ - # $WEB_colour_map_yellow\ - # $WEB_colour_map_brown\ - # $WEB_colour_map_purple\ - # $WEB_colour_map_blue\ - # $WEB_colour_map_cyan\ - # $WEB_colour_map_green\ - # $WEB_colour_map_white\ - # $WEB_colour_map_gray\ - #] - proc colourtable_web {args} { - set opts {-forcecolour 0 -groups *} - foreach {k v} $args { - switch -- $k { - -groups - -forcecolour { - tcl::dict::set opts $k $v - } - default { - error "colourtable_web unrecognised option '$k'. Known-options: [tcl::dict::keys $defaults]" - } - } - } - set fc "" - if {[tcl::dict::get $opts -forcecolour]} { - set fc "forcecolour" - } - set groups [tcl::dict::get $opts -groups] - - #set all_groupnames [list basic pink red orange yellow brown purple blue cyan green white gray] - set all_groupnames [list basic brown yellow red pink orange purple blue cyan green white gray] - switch -- $groups { - "" - * { - set show_groups $all_groupnames - } - ? { - return "Web group names: $all_groupnames" - } - default { - foreach g $groups { - if {$g ni $all_groupnames} { - error "colourtable_web group name '$g' not known. Known colour groups: $all_groupnames" - } - } - set show_groups $groups - } - } - set grouptables [list] - #set white_fg_list [list\ - # mediumvioletred deeppink\ - # darkred red firebrick crimson indianred\ - # orangered\ - # maroon brown saddlebrown sienna\ - # indigo purple darkmagenta darkviolet darkslateblue blueviolet darkorchid fuchsia magenta slateblue mediumslateblue\ - # midnightblue navy darkblue mediumblue blue royalblue steelblue dodgerblue\ - # teal darkcyan\ - # darkgreen green darkolivegreen forestgreen seagreen olive olivedrab\ - # black darkslategray dimgray slategray\ - # ] - foreach g $show_groups { - #upvar WEB_colour_map_$g map_$g - variable WEB_colour_map_$g - set t [textblock::class::table new] - $t configure -show_edge 0 -show_seps 0 -show_header 1 - tcl::dict::for {cname cdec} [set WEB_colour_map_$g] { - $t add_row [list "$cname " "[colour_dec2hex $cdec] " $cdec] - set fg "rgb-$cdec-contrasting" - #if {$cname in $white_fg_list} { - # set fg "web-white" - #} else { - # set fg "web-black" - #} - #$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Rgb-$cdec] - $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Web-$cname] - } - $t configure -frametype {} - $t configure_column 0 -headers [list "[tcl::string::totitle $g] colours"] - $t configure_column 0 -header_colspans [list any] - $t configure -ansibase_header [a+ {*}$fc web-black Web-white] - lappend grouptables [$t print] - $t destroy - } - #set displaytable [textblock::class::table new] - set displaytable [textblock::list_as_table -columns 3 -return tableobject $grouptables] - $displaytable configure -show_header 0 -show_vseps 0 - #return $displaytable - set result [$displaytable print] - $displaytable destroy - return $result - } - proc colourtable_x11diff {args} { - variable X11_colour_map_diff - variable WEB_colour_map - set opts [tcl::dict::create\ - -forcecolour 0\ - -return "string"\ - ] - foreach {k v} $args { - switch -- $k { - -return - -forcecolour { - tcl::dict::set opts $k $v - } - default { - error "colourtable_x11diff unrecognised option '$k'. Known options [tcl::dict::keys $opts]" - } - } - } - set fc "" - if {[tcl::dict::get $opts -forcecolour]} { - set fc "forcecolour" - } - - set comparetables [list] ;# 2 side by side x11 and web - - # -- --- --- - set t [textblock::class::table new] - $t configure -show_edge 0 -show_seps 0 -show_header 1 - tcl::dict::for {cname cdec} [set X11_colour_map_diff] { - $t add_row [list "$cname " "[colour_dec2hex $cdec] " $cdec] - set fg "web-white" - $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg X11-$cname] - } - $t configure -frametype block - $t configure_column 0 -headers [list "X11"] - $t configure_column 0 -header_colspans [list any] - $t configure -ansibase_header [a+ {*}$fc web-black Web-white] - lappend comparetables [$t print] - $t destroy - # -- --- --- - - set WEB_map_subset [tcl::dict::create] - tcl::dict::for {k v} $X11_colour_map_diff { - tcl::dict::set WEB_map_subset $k [tcl::dict::get $WEB_colour_map $k] - } - - # -- --- --- - set t [textblock::class::table new] - $t configure -show_edge 0 -show_seps 0 -show_header 1 - tcl::dict::for {cname cdec} [set WEB_map_subset] { - $t add_row [list "$cname " "[colour_dec2hex $cdec] " $cdec] - set fg "web-white" - $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Web-$cname] - } - $t configure -frametype block - $t configure_column 0 -headers [list "Web"] - $t configure_column 0 -header_colspans [list any] - $t configure -ansibase_header [a+ {*}$fc web-black Web-white] - lappend comparetables [$t print] - $t destroy - # -- --- --- - - set displaytable [textblock::list_as_table -columns 2 -return tableobject $comparetables] - $displaytable configure -show_header 0 -show_vseps 0 - - if {[tcl::dict::get $opts -return] eq "string"} { - set result [$displaytable print] - $displaytable destroy - return $result - } - - return $displaytable - } - lappend PUNKARGS [list { - @id -id ::punk::ansi::a? - @cmd -name "punk::ansi::a?"\ - -summary\ - "ANSI colour information"\ - -help\ - "" - @form -form "sgr_overview" - @values -form "sgr_overview" -min 0 -max 0 - - - @form -form "term" - @leaders -form "term" -min 1 -max 1 - term -type literal(term) -help\ - "256 term colours" - @opts -min 0 -max 0 - @values -form "term" -min 0 -max -1 - panel -type string -optional 1 -multiple 1 -default {16 main greyscale note}\ - -choices {16 main greyscale pastel rainbow note} - - @form -form "tk" - @leaders -form "tk" -min 1 -max 1 - tk -type literal(tk)|literal(TK) -help\ - "Tk colours" - @opts -form "tk" - -merged -type none -help\ - "If this flag is supplied - show colour names with the same RGB - values together." - @values -form "tk" -min 0 -max -1 - glob -type string -optional 1 -multiple 1 -help\ - "A glob string such as *green*. - Multiple glob entries can be provided. The search is case insensitive" - - - @form -form "web" - @values -form "web" -min 1 -max -1 - web -type literal(web) -help\ - "Web colours" - panel -type string -optional 1 -multiple 1 -choices {basic pink red orange yellow brown purple blue cyan green white gray} - - @form -form "x11" - @values -form "x11" -min 1 -max 1 - x11 -type literal(x11) -help\ - "x11 colours" - - - @form -form "sample" - @values -form "sample" -min 1 -max -1 - colourcode -type sgr|Sgr|literalprefix(term-)|literalprefix(Term-)|literalprefix(web-)|literalprefix(Web-)|literalprefix(rgb)|literalprefix(Rgb)\ - -optional 0\ - -multiple 1 - - }] - proc a? {args} { - #*** !doctools - #[call [fun a?] [opt {ansicode...}]] - #[para]Return an ansi string representing a table of codes and a panel showing the colours - variable SGR_setting_map - variable SGR_colour_map - variable TK_colour_map_lookup - set fcposn [lsearch $args "force*"] - set fc "" - set opt_forcecolour 0 - if {$fcposn >= 0} { - set fc "forcecolour" - set opt_forcecolour 1 - set args [lremove $args $fcposn] - } - - if {![llength $args]} { - set out "" - set indent " " - set RST [a] - append out "[a+ {*}$fc web-white]Extended underlines$RST" \n - set undercurly "undercurly \[a+ undercurly und-199-21-133\]text\[a] -> [a+ undercurly und-199-21-133]text$RST" - set underdotted "underdotted \[a+ underdotted und#FFD700\]text\[a] -> [a+ underdotted und#FFD700]text$RST" - set underdashed "underdashed \[a+ underdashed undt-45\]text\[a] -> [a+ underdashed undt-45]text$RST" - set underline_c "named terminal colour SGR underline \[a+ underline undt-deeppink1\]text\[a] -> [a+ underline undt-deeppink1]text$RST" - append out "${indent}$undercurly $underdotted" \n - append out "${indent}$underdashed" \n - append out "${indent}$underline_c" \n - append out "${indent}Extended underlines/colours can suppress other SGR codes on terminals that don't support them if codes are merged." \n - append out "${indent}punk::ansi tries to keep them in separate escape sequences (standard SGR followed by extended) even during merge operations to avoid this." \n - append out "${indent}If a fallback to standard underline is required, underline should be added along with extended codes such as underlinedotted, underlinedouble etc" \n - append out "${indent}e.g cyan with curly yellow underline or fallback all cyan underlined \[a+ cyan undercurly underline undt-yellow\]text\[a] -> [a+ {*}$fc cyan undercurly underline undt-yellow]text$RST" \n - append out "[a+ {*}$fc web-white]Standard SGR colours and attributes $RST" \n - set settings_applied $SGR_setting_map - set strmap [list] - #safe jumptable test - #dict for {k v} $SGR_setting_map {} - tcl::dict::for {k v} $SGR_setting_map { - switch -- $k { - bold - dim - italic - doubleunderline - blink - fastblink - strike - overline - framecircle { - lappend strmap " $k " " [a+ $k]$k$RST " - } - noreverse - nounderline { - #prefixed version will match before unprefixed - will not be subject to further replacement scanning - lappend strmap "$k" "[a+ $k]$k$RST" ;#could replace with self - but may as well put in punk::ansi::sgr_cache (can make cache a little neater to display) - } - underline - reverse - frame { - #1st coloumn - no leading space - lappend strmap "$k " "[a+ $k]$k$RST " - } - } - } - set settings_applied [tcl::string::trim $SGR_setting_map \n] - try { - package require overtype ;# circular dependency - many components require overtype. Here we only need it for nice layout in the a? query proc - so we'll do a soft-dependency by only loading when needed and also wrapping in a try - package require textblock - - append out [textblock::join -- $indent [tcl::string::map $strmap $settings_applied]] \n - append out [textblock::join -- $indent [tcl::string::trim $SGR_colour_map \n]] \n - append out [textblock::join -- $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n - set bgname "Web-white" - set map1 [colourmap1 -bg $bgname -forcecolour $opt_forcecolour] - set map1 [overtype::centre -transparent 1 $map1 "[a {*}$fc black $bgname]Standard colours[a]"] - set map2 [colourmap2 -bg $bgname -forcecolour $opt_forcecolour] - set map2 [overtype::centre -transparent 1 $map2 "[a {*}$fc black $bgname]High-intensity colours[a]"] - append out [textblock::join -- $indent [textblock::join -- $map1 $map2]] \n - append out "[a+ {*}$fc web-white]216 colours of 256 terminal colours (To see names, use: a? term ?pastel? ?rainbow?)[a]" \n - append out [textblock::join -- $indent [colourblock_216 -forcecolour $opt_forcecolour]] \n - append out "[a+ {*}$fc web-white]24 Greyscale colours[a]" \n - append out [textblock::join -- $indent [colourblock_24 -forcecolour $opt_forcecolour]] \n - append out \n - append out [textblock::join -- $indent "Example: \[a+ Term-92 term-49\]text\[a] -> [a+ {*}$fc Term-92 term-49]text[a]"] \n - append out [textblock::join -- $indent "Example: \[a+ Term-lightsteelblue term-gold1\]text\[a] -> [a+ {*}$fc Term-lightsteelblue term-gold1]text[a]"] \n - append out [textblock::join -- $indent "Example: \[a+ term-lightsteelblue Term-gold1\]text\[a] -> [a+ {*}$fc term-lightsteelblue Term-gold1]text[a]"] \n - append out \n - append out "[a+ {*}$fc web-white]16 Million colours[a]" \n - #tcl::dict::set WEB_colour_map mediumvioletred 199-21-133 ;# #C71585 - append out [textblock::join -- $indent "Example: \[a+ rgb-199-21-133\]text\[a] -> [a+ {*}$fc rgb-199-21-133]text[a]"] \n - append out [textblock::join -- $indent "Example: \[a+ Rgb#C71585\]text\[a] -> [a+ {*}$fc Rgb#C71585]text[a]"] \n - append out [textblock::join -- $indent "Examine a sequence: a? bold rgb-46-139-87 Rgb#C71585 "] \n - append out \n - append out "[a+ {*}$fc web-white]Web colours[a]" \n - append out [textblock::join -- $indent "To see all names use: a? web"] \n - append out [textblock::join -- $indent "To see specific colour groups use: a? web groupname1 groupname2..."] \n - append out [textblock::join -- $indent "Valid group names (can be listed in any order): basic pink red orange yellow brown purple blue cyan green white grey"] \n - append out \n - append out [textblock::join -- $indent "Example: \[a+ Web-springgreen web-crimson\]text\[a] -> [a+ {*}$fc Web-springgreen web-coral]text[a]"] \n - append out \n - append out "[a+ {*}$fc web-white]X11 colours[a] - mostly match Web colours" \n - append out [textblock::join -- $indent "To see differences: a? x11"] \n - append out \n - append out "[a+ {*}$fc web-white]Tk colours[a]" \n - append out [textblock::join -- $indent "To see all 750+ names use: a? tk"] \n - append out [textblock::join -- $indent "Restrict the results using globs e.g a? tk *green* *yellow*"] \n - append out [textblock::join -- $indent "The foreground colour in this table is generated using the contrasting suffix"] \n - append out [textblock::join -- $indent "Example: \[a+ tk-tan-contrasting Tk-tan\]text\[a] -> [a+ {*}$fc tk-tan-contrasting Tk-tan]text[a]"] \n - append out \n - append out "[a+ {*}$fc web-white]Combination testing[a]" \n - append out [textblock::join -- $indent "Example: a? red brightgreen underline Tk-slategrey italic"] \n - append out [textblock::join -- $indent "This will show a small table of each applied code and a RESULT row. The 'red' in this case is redundant,"] \n - append out [textblock::join -- $indent "so a final MERGED row displays with an alert 'REDUNDANCIES FOUND'."] \n - append out [textblock::join -- $indent "The final columns of RESULT and MERGED (showing raw ANSI sequence) will differ if the arguments aren't in canonical order."] \n - append out [textblock::join -- $indent "The MERGED line will only display if there are redundancies or different ordering."] \n - - - if {[tcl::info::exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { - append out \n - if {$fc ne ""} { - append out "[a+ {*}$fc web-white]Colour is currently disabled - returning with colour anyway because 'forcecolour' argument was supplied[a]" \n - } else { - append out "Colour is currently disabled - to return with colour anyway - add the 'forcecolour' argument" \n - } - } - - } on error {result options} { - puts stderr "Failed to draw colourmap" - puts stderr "$result" - } finally { - return $out - } - } else { - switch -- [lindex $args 0] { - term { - set argd [punk::args::parse $args -form "term" -errorstyle standard withid ::punk::ansi::a?] - lassign [dict values $argd] leaders opts values received - set panels [dict get $values panel] - - set out "" - foreach panel $panels { - #punk::args has already resolved prefixes to full panel names - switch -- $panel { - 16 { - append out "16 basic colours\n" - append out [colourtable_16_names -forcecolour $opt_forcecolour] \n - } - main { - append out "216 colours\n" - append out [colourtable_216_names -forcecolour $opt_forcecolour] \n - } - note { - append out "\nNote: The 256 term colours especially 0-15 may be altered by terminal palette settings or ansi OSC 4 codes, so specific RGB values are unavailable" \n - append out " grey vs gray (UK/US spelling) - these are inconsistent for historical reasons. e.g grey0,lightslategrey,darkslategray1" \n - } - greyscale { - append out "24 greyscale colours\n" - append out [colourtable_24_names -forcecolour $opt_forcecolour] \n - } - pastel { - append out "Pastel Colour Space (punk::ansi::colourtable_term_pastel)\n" - append out [colourtable_term_pastel -forcecolour $opt_forcecolour] \n - } - rainbow { - append out "Rainbow Colours (punk::ansi::colourtable_term_rainbow)\n" - append out [colourtable_term_rainbow -forcecolour $opt_forcecolour] \n - } - default { - #only reachable if punk::args definition is out of sync - set panelnames {16 main greyscale pastel rainbow note} - append out "(ERROR: unrecognised panel '$ta' for 'a? term'. Known values $panelnames)" - } - } - } - return $out - } - web { - set argd [punk::args::parse $args -form "web" -errorstyle standard withid ::punk::ansi::a?] - lassign [dict values $argd] leaders opts values received - if {[dict exists $received panel]} { - set panels [dict get $values panel] - } else { - set panels {*} - } - return [colourtable_web -forcecolour $opt_forcecolour -groups $panels] - } - tk - TK { - set argd [punk::args::parse $args -form "tk" -errorstyle standard withid ::punk::ansi::a?] - lassign [dict values $argd] leaders opts values received - if {[dict exists $received glob]} { - set globs [dict get $values glob] - } else { - set globs {*} - } - if {[dict exists $received -merged]} { - set ismerged 1 - } else { - set ismerged 0 - } - return [colourtable_tk -merged $ismerged -forcecolour $opt_forcecolour -globs $globs] - } - x11 { - set argd [punk::args::parse $args -form "x11" -errorstyle standard withid ::punk::ansi::a?] - set out "" - append out " Mostly same as web - known differences displayed" \n - append out [colourtable_x11diff -forcecolour $opt_forcecolour] - return $out - } - } - - variable WEB_colour_map - variable X11_colour_map - variable TERM_colour_map - variable TERM_colour_map_reverse - variable SGR_map - - set t [textblock::class::table new] - $t configure -show_edge 0 -show_seps 1 -show_header 0 - - set resultlist [list] - foreach i $args { - #set f4 [tcl::string::range $i 0 3] - set pfx [lindex [::split $i "-# "] 0] - set s [a+ {*}$fc $i]sample - switch -- $pfx { - web - Web - WEB { - set tail [tcl::string::tolower [tcl::string::trim [tcl::string::range $i 4 end] -]] - set cont [string range $tail end-11 end] - switch -- $cont { - -contrasting - -contrastive { - set cname [string range $tail 0 end-12] - } - default { - set cname $tail - } - } - if {[tcl::dict::exists $WEB_colour_map $cname]} { - set dec [tcl::dict::get $WEB_colour_map $cname] - switch -- $cont { - -contrasting { - set dec [join [punk::ansi::colour::contrasting {*}[split $dec -]] -] - } - -contrastive { - set dec [join [lindex [punk::ansi::colour::contrast_pair {*}[split $dec -]] 0] -] - } - } - set hex [colour_dec2hex $dec] - set descr "$hex $dec" - } else { - set descr "UNKNOWN colour for web" - } - $t add_row [list $i $descr $s [ansistring VIEW $s]] - } - term - Term - undt { - set tail [tcl::string::range $i 5 end] - if {[tcl::string::is integer -strict $tail]} { - if {$tail < 256} { - set descr "[tcl::dict::get $TERM_colour_map_reverse $tail]" - } else { - set descr "Invalid (> 255)" - } - } else { - set tail [tcl::string::tolower $tail] - if {[tcl::dict::exists $TERM_colour_map $tail]} { - set descr [tcl::dict::get $TERM_colour_map $tail] - } else { - set descr "UNKNOWN colour for term" - } - } - $t add_row [list $i $descr $s [ansistring VIEW $s]] - } - x11 - X11 { - set cname [tcl::string::tolower [tcl::string::range $i 4 end]] - set cont [string range $cname end-11 end] - switch -exact -- $cont {-contrasting - -contrastive {set cname [string range $tail end-12]}} - - if {[tcl::dict::exists $X11_colour_map $cname]} { - set dec [tcl::dict::get $X11_colour_map $cname] - set hex [colour_dec2hex $dec] - set descr "$hex $dec" - } else { - set descr "UNKNOWN colour for x11" - } - $t add_row [list $i $descr $s [ansistring VIEW $s]] - } - tk - Tk { - set tail [tcl::string::tolower [tcl::string::range $i 3 end]] - set cont [string range $tail end-11 end] - switch -- $cont { - -contrasting - -contrastive { - set cname [string range $tail 0 end-12] - } - default { - set cname $tail - } - } - if {[tcl::dict::exists $TK_colour_map_lookup $cname]} { - set dec [tcl::dict::get $TK_colour_map_lookup $cname] - set hex [colour_dec2hex $dec] - set descr "$hex $dec" - } else { - set descr "UNKNOWN colour for tk" - } - $t add_row [list $i $descr $s [ansistring VIEW $s]] - } - rgb - Rgb - RGB - und { - set cont [string range $i end-11 end] - switch -- $cont { - -contrasting - -contrastive { - set iplain [string range $i 0 end-12] - } - default { - set iplain $i - } - } - if {[tcl::string::index $iplain 3] eq "#"} { - set tail [tcl::string::range $iplain 4 end] - set hex $tail - set dec [colour_hex2dec $hex] - - switch -- $cont { - -contrasting { - set decfinal [join [punk::ansi::colour::contrasting {*}[split $dec -]] -] - set hexfinal [colour_dec2hex $decfinal] - } - -contrastive { - set decfinal [join [lindex [punk::ansi::colour::contrast_pair {*}[split $dec -]] 0] -] - set hexfinal [colour_dec2hex $decfinal] - } - default { - set hexfinal $hex - set decfinal $dec - } - } - set info "$hexfinal $decfinal" ;#show opposite type as first line of info col - } else { - set tail [tcl::string::range $iplain 4 end] - set dec $tail - switch -- $cont { - -contrasting { - set decfinal [join [punk::ansi::colour::contrasting {*}[split $dec -]] -] - } - -contrastive { - set decfinal [join [lindex [punk::ansi::colour::contrast_pair {*}[split $dec -]] 0] -] - } - default { - set decfinal $dec - } - } - set hexfinal [colour_dec2hex $decfinal] - set info "$hexfinal $decfinal" - } - - set webcolours_i [lsearch -all $WEB_colour_map $decfinal] - set webcolours [list] - foreach ci $webcolours_i { - lappend webcolours [lindex $WEB_colour_map $ci-1] - } - set x11colours [list] - set x11colours_i [lsearch -all $X11_colour_map $decfinal] - foreach ci $x11colours_i { - set c [lindex $X11_colour_map $ci-1] - if {$c ni $webcolours} { - lappend x11colours $c - } - } - if {[dict exists $::punk::ansi::colourmap::TK_colour_map_reverse $decfinal]} { - set tkcolours [dict get $::punk::ansi::colourmap::TK_colour_map_reverse $decfinal] - } else { - set tkcolours [list] - } - foreach c $webcolours { - append info \n web-$c - } - foreach c $x11colours { - append info \n x11-$c - } - foreach c $tkcolours { - append info \n tk-$c - } - $t add_row [list $i "$info" $s [ansistring VIEW $s]] - } - default { - switch -- $i { - undercurly - undercurl - underdotted - underdot - underdashed - underdash - undersingle - underdouble { - $t add_row [list $i extended $s [ansistring VIEW $s]] - } - underline { - $t add_row [list $i "SGR 4" $s [ansistring VIEW $s]] - } - underlinedefault { - $t add_row [list $i "SGR 59" $s [ansistring VIEW $s]] - } - default { - #$t add_row [list $i UNKNOWN $s [ansistring VIEW $s]] - if {[tcl::string::is integer -strict $i]} { - set rmap [lreverse $SGR_map] - $t add_row [list $i "SGR [tcl::dict::get $rmap $i]" $s [ansistring VIEW $s]] - } else { - if {[tcl::dict::exists $SGR_map $i]} { - $t add_row [list $i "SGR [tcl::dict::get $SGR_map $i]" $s [ansistring VIEW $s]] - } else { - $t add_row [list $i UNKNOWN $s [ansistring VIEW $s]] - } - } - } - } - } - } - } - set ansi [a+ {*}$fc {*}$args] - set s ${ansi}sample - #set merged [punk::ansi::codetype::sgr_merge_singles [list $ansi]] - set merged [punk::ansi::codetype::sgr_merge [list $ansi]] - set s2 ${merged}sample - #lappend resultlist "RESULT: [a+ {*}$args]sample[a]" - $t add_row [list RESULT "" $s [ansistring VIEW $s]] - if {$ansi ne $merged} { - if {[tcl::string::length $merged] < [tcl::string::length $ansi]} { - #only refer to redundancies if shorter - merge may reorder - REVIEW - set warning "[a+ web-red Web-yellow]REDUNDANCIES FOUND" - } else { - set warning "" - } - $t add_row [list MERGED $warning $s2 [ansistring VIEW $s2]] - } - set result [$t print] - $t destroy - return $result - } - } - - #REVIEW! note that OSC 4 can change the 256 color pallette - #e.g \x1b\]4\;1\;#HHHHHH\x1b\\ - # (or with colour name instead of rgb #HHHHHH on for example wezterm) - - #Q: If we can't detect OSC 4 - how do we know when to invalidate/clear at least the 256 color portion of the cache? - #A: The cache values should still be valid - and the terminal should display the newly assigned colour. - # If in line mode - perhaps readline or something else is somehow storing the rgb values and replaying invalid colours? - # On wezterm - we can get cells changing colour as we scroll after a pallette change - so something appears to be caching colours - - variable sgr_cache - set sgr_cache [tcl::dict::create] - - #sgr_cache clear called by punk::console::ansi when set to off - - #punk::args depends on punk::ansi - REVIEW - lappend PUNKARGS [list { - @id -id ::punk::ansi::sgr_cache - @cmd -name punk::ansi::sgr_cache -help\ - "Convenience function to view and optionally clear the ansi character attribute cache - (ansi SGR codes)" - -action -default "" -choices "clear" -help\ - "-action clear will unset the keys in the punk::ansi::sgr_cache dict - This is called automatically when setting 'colour false' in the console" - - -pretty -default 1 -type boolean -help\ - "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output" - @values -min 0 -max 0 - }] - proc sgr_cache {args} { - set argd [punk::args::get_by_id ::punk::ansi::sgr_cache $args] - set action [dict get $argd opts -action] - set pretty [dict get $argd opts -pretty] - - variable sgr_cache - if {$action eq "clear"} { - set sgr_cache [tcl::dict::create] - return "sgr_cache cleared" - } - if {$pretty} { - #return [pdict -channel none sgr_cache */%str,%ansiview] - return [punk::lib::pdict -channel none sgr_cache */%rpadstr-"sample",%ansiviewstyle] - } - - if {[catch { - set termwidth [tcl::dict::get [punk::console::get_size] columns] - } errM]} { - set termwidth 80 - } - set termwidth [expr [$termwidth -3]] - set out "" - set linelen 0 - set RST [a] - set lines [list] - set line "" - #todo - terminal width? table? - tcl::dict::for {key ansi} $sgr_cache { - set thislen [expr {[tcl::string::length $key]+1}] - if {$linelen + $thislen >= $termwidth-1} { - lappend lines $line - set line "$ansi$key$RST " - set linelen $thislen - } else { - append line "$ansi$key$RST " - incr linelen $thislen - } - } - if {[tcl::string::length $line]} { - lappend lines $line - } - return [join $lines \n] - } - - #PUNKARGS doc performed below, after we create the proc - proc a+ {args} { - #*** !doctools - #[call [fun a+] [opt {ansicode...}]] - #[para]Returns the ansi code to apply those from the supplied list - without any reset being performed first - #[para] e.g to set foreground red and bold - #[para]punk::ansi::a red bold - #[para]to set background red - #[para]punk::ansi::a Red - #[para]see [cmd punk::ansi::a?] to display a list of codes - - #function name part of cache-key because a and a+ return slightly different results (a has leading reset) - variable sgr_cache - set cache_key "a+ $args" ;#ensure cache_key static - we may remove for example 'forcecolour' from args - but it needs to remain part of cache_key - if {[tcl::dict::exists $sgr_cache $cache_key]} { - return [tcl::dict::get $sgr_cache $cache_key] - } - - #don't disable ansi here. - #we want this to be available to call even if ansi is off - variable WEB_colour_map - variable TERM_colour_map - - - set colour_disabled 0 - #whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache clear - if {[tcl::info::exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { - set colour_disabled 1 - } - #allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything. - set forcecolour 0 - set fcpos [lsearch $args "force*"] ;#allow forcecolor forcecolour - if {$fcpos >= 0} { - set forcecolour 1 - set args [lremove $args $fcpos] - } - - set t [list] - set e [list] ;#extended codes needing to go in own escape sequence - foreach i $args { - set pfx [lindex [::split $i "-# "] 0] - #set f4 [tcl::string::range $i 0 3] - switch -- $pfx { - web { - #variable WEB_colour_map - #upvar ::punk::ansi::WEB_colour_map WEB_colour_map - #foreground web colour - set cname [tcl::string::tolower [tcl::string::range $i 4 end]] - #-contrasting - #-contrastive - set cont [string range $cname end-11 end] - switch -- $cont { -contrasting - -contrastive {set cname [string range $cname 0 end-12]} } - - if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] - switch -- $cont { - -contrasting { - set rgb [join [punk::ansi::colour::contrasting {*}[split $rgbdash -]] {;}] - } - -contrastive { - set rgb [join [lindex [punk::ansi::colour::contrast_pair {*}[split $rgbdash -]] 0] {;}] - } - default { - set rgb [tcl::string::map { - ;} $rgbdash] - } - } - lappend t "38;2;$rgb" - } else { - puts stderr "ansi web colour unmatched: '$i' in call 'a+ $args'" - } - } - Web - WEB { - #variable WEB_colour_map - #upvar ::punk::ansi::WEB_colour_map WEB_colour_map - #background web colour - set tail [tcl::string::tolower [tcl::string::range $i 4 end]] - set cont [string range $tail end-11 end] - switch -- $cont { - -contrasting - -contrastive { - set cname [string range $tail 0 end-12] - } - default { - set cname $tail - } - } - if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] - switch -- $cont { - -contrasting { - set rgb [join [punk::ansi::colour::contrasting {*}[split $rgbdash -]] {;}] - } - -contrastive { - set rgb [join [lindex [punk::ansi::colour::contrast_pair {*}[split $rgbdash -]] 0] {;}] - } - default { - set rgb [tcl::string::map { - ;} $rgbdash] - } - } - lappend t "48;2;$rgb" - } else { - puts stderr "ansi Web colour unmatched: '$i' in call 'a+ $args'" - } - } - reset {lappend t 0} - bold {lappend t 1} - dim {lappend t 2} - blink {lappend t 5} - fastblink {lappend t 6 } - noblink {lappend t 25} - hide {lappend t 8} - normal {lappend t 22} - underline {lappend t 4} - underlinedefault {lappend t 59} - underextendedoff { - #lremove any existing 4:1 etc - #NOTE struct::set result order can differ depending on whether tcl/critcl imp used - #set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] - set e [punk::lib::ldiff $e [list 4:1 4:2 4:3 4:4 4:5]] - lappend e 4:0 - } - undersingle { - lappend e 4:1 - } - underdouble { - lappend e 4:2 - } - undercurly - undercurl { - lappend e 4:3 - } - underdotted - underdot { - lappend e 4:4 - } - underdashed - underdash { - #TODO - fix - # extended codes with colon suppress normal SGR attributes when in same escape sequence on terminal that don't support the extended codes. - # need to emit in - lappend e 4:5 - } - doubleunderline {lappend t 21} - nounderline { - lappend t 24 ;#nounderline - #set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] - lappend e 4:0 - } - strike {lappend t 9} - nostrike {lappend t 29} - italic {lappend t 3} - noitalic {lappend t 23} - reverse {lappend t 7} - noreverse {lappend t 27} - defaultfg {lappend t 39} - defaultbg {lappend t 49} - defaultund {lappend t 59} - nohide {lappend t 28} - overline {lappend t 53} - nooverline {lappend t 55} - frame {lappend t 51} - framecircle {lappend t 52} - noframe {lappend t 54} - black {lappend t 30} - red {lappend t 31} - green {lappend t 32} - yellow {lappend t 33} - blue {lappend t 34} - purple {lappend t 35} - cyan {lappend t 36} - white {lappend t 37} - Black {lappend t 40} - Red {lappend t 41} - Green {lappend t 42} - Yellow {lappend t 43} - Blue {lappend t 44} - Purple {lappend t 45} - Cyan {lappend t 46} - White {lappend t 47} - brightblack {lappend t 90} - brightred {lappend t 91} - brightgreen {lappend t 92} - brightyellow {lappend t 93} - brightblue {lappend t 94} - brightpurple {lappend t 95} - brightcyan {lappend t 96} - brightwhite {lappend t 97} - Brightblack {lappend t 100} - Brightred {lappend t 101} - Brightgreen {lappend t 102} - Brightyellow {lappend t 103} - Brightblue {lappend t 104} - Brightpurple {lappend t 105} - Brightcyan {lappend t 106} - Brightwhite {lappend t 107} - term { - #variable TERM_colour_map - #256 colour foreground by Xterm name or by integer - #name is xterm name or colour index from 0 - 255 - set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] - if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend t "38;5;$cc" - } else { - if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" - } else { - puts stderr "ansi term colour unmatched: '$i' in call 'a+ $args'" - } - } - } - Term - TERM { - #variable TERM_colour_map - #256 colour background by Xterm name or by integer - set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] - if {[tcl::string::is integer -strict $cc] && $cc < 256} { - lappend t "48;5;$cc" - } else { - if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" - } else { - puts stderr "ansi Term colour unmatched: '$i' in call 'a+ $args'" - } - } - } - rgb - Rgb - RGB { - set utype [string index $i 3] - if {$utype eq "-"} { - #decimal rgb foreground/background - #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx - set cont [string range $i end-11 end] - switch -- $cont { - -contrasting - -contrastive { - set iplain [string range $i 0 end-12] - } - default { - set iplain $i - } - } - set rgbspec [tcl::string::range $iplain 4 end] - set RGB [tcl::string::map [list - { } , { } {;} { }] $rgbspec] ;#RGB as list - switch -- $cont { - -contrasting { - set rgbfinal [join [punk::ansi::colour::contrasting {*}$RGB] {;}] - } - -contrastive { - set rgbfinal [join [lindex [punk::ansi::colour::contrast_pair {*}$RGB] 0] {;}] - } - default { - set rgbfinal [join $RGB {;}] - } - } - if {[tcl::string::index $i 0] eq "r"} { - #fg - lappend t "38;2;$rgbfinal" - } else { - #bg - lappend t "48;2;$rgbfinal" - } - - } elseif {$utype eq "#"} { - set hex6 [tcl::string::range $i 4 end] - #set rgb [join [::scan $hex6 %2X%2X%2X] {;}] - set RGB [::scan $hex6 %2X%2X%2X] - set cont [string range $i end-11 end] - switch -- $cont { - -contrasting { - set rgbfinal [join [punk::ansi::colour::contrasting {*}$RGB] {;}] - } - -contrastive { - set rgbfinal [join [lindex [punk::ansi::colour::contrast_pair {*}$RGB] 0] {;}] - } - default { - set rgbfinal [join $RGB {;}] - } - } - if {[tcl::string::index $i 0] eq "r"} { - #hex rgb foreground - lappend t "38;2;$rgbfinal" - } else { - #hex rgb background - lappend t "48;2;$rgbfinal" - } - } else { - puts stderr "punk::ansi::a+ ansi term rgb colour unmatched: '$i' in call 'a+ $args'" - } - } - und { - set utype [string index $i 3] - if {$utype eq "-"} { - #decimal rgb underline - #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx - #https://wezfurlong.org/wezterm/escape-sequences.html#csi-582-underline-color-rgb - set rgbspec [tcl::string::range $i 4 end] - set RGB [lrange [tcl::string::map [list - { } , { } {;} { }] $rgbspec] 0 2] - #puts "---->'$RGB'<----" - set cont [string range $i end-11 end] - switch -- $cont { - -contrasting { - set rgbfinal [join [punk::ansi::colour::contrasting {*}$RGB] {:}] - } - -contrastive { - set rgbfinal [join [lindex [punk::ansi::colour::contrast_pair {*}$RGB] 0] {:}] - } - default { - set rgbfinal [join $RGB {:}] - } - } - #lappend e "58:2:$rgbfinal" ;# - no colorspace ID - some terminals support? which? - lappend e "58:2::$rgbfinal" - } elseif {$utype eq "#"} { - #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators - set hex6 [tcl::string::range $i 4 end] - #set rgb [join [::scan $hex6 %2X%2X%2X] {:}] - set RGB [::scan $hex6 %2X%2X%2X] - set cont [string range $i end-11 end] - switch -- $cont { - -contrasting { - set rgbfinal [join [punk::ansi::colour::contrasting {*}$RGB] {:}] - } - -contrastive { - set rgbfinal [join [lindex [punk::ansi::colour::contrast_pair {*}$RGB] 0] {:}] - } - default { - set rgbfinal [join $RGB {:}] - } - } - lappend e "58:2::$rgbfinal" - } else { - puts stderr "punk::ansi::a+ ansi term underline colour unmatched: '$i' in call 'a+ $args'" - } - } - undt { - # CSI 58:5 UNDERLINE COLOR PALETTE INDEX - # CSI 58 : 5 : INDEX m - # variable TERM_colour_map - # 256 colour underline by Xterm name or by integer - #name is xterm name or colour index from 0 - 255 - set cc [tcl::string::tolower [tcl::string::range $i 5 end]] - if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend e "58:5:$cc" - } else { - if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" - } else { - puts stderr "ansi term underline colour unmatched: '$i' in call 'a $args'" - } - } - } - x11 { - variable X11_colour_map - #foreground X11 names - set cname [tcl::string::tolower [tcl::string::range $i 4 end]] - if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] - set rgb [tcl::string::map [list - {;}] $rgbdash] - lappend t "38;2;$rgb" - } else { - puts stderr "ansi x11 foreground colour unmatched: '$i' in call 'a+ $args'" - } - } - X11 { - variable X11_colour_map - #background X11 names - set cname [tcl::string::tolower [tcl::string::range $i 4 end]] - if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] - set rgb [tcl::string::map [list - {;}] $rgbdash] - lappend t "48;2;$rgb" - } else { - puts stderr "ansi X11 background colour unmatched: '$i'" - } - } - tk { - #foreground tk names - variable TK_colour_map_lookup ;#use the dict with added lowercase versions - - set cname [tcl::string::tolower [tcl::string::range $i 3 end]] - lassign [punk::lib::string_splitbefore $cname end-11] c cont - switch -exact -- $cont { -contrasting - -contrastive {set cname $c} } - - if {[tcl::dict::exists $TK_colour_map_lookup $cname]} { - set rgbdash [tcl::dict::get $TK_colour_map_lookup $cname] - switch -- $cont { - -contrasting { - set rgb [join [punk::ansi::colour::contrasting {*}[split $rgbdash -]] {;}] - } - -contrastive { - set rgb [join [lindex [punk::ansi::colour::contrast_pair {*}[split $rgbdash -]] 0] {;}] - } - default { - set rgb [tcl::string::map { - ;} $rgbdash] - } - } - lappend t "38;2;$rgb" - } else { - puts stderr "ansi tk foreground colour unmatched: '$i' in call 'a+ $args'" - } - } - Tk - TK { - #background X11 names - variable TK_colour_map_lookup ;#with lc versions - - set cname [tcl::string::tolower [tcl::string::range $i 3 end]] - lassign [punk::lib::string_splitbefore $cname end-11] c cont - switch -- $cont { -contrasting - -contrastive {set cname $c} } - - if {[tcl::dict::exists $TK_colour_map_lookup $cname]} { - set rgbdash [tcl::dict::get $TK_colour_map_lookup $cname] - switch -- $cont { - -contrasting { - set rgb [join [punk::ansi::colour::contrasting {*}[split $rgbdash -]] {;}] - } - -contrastive { - set rgb [join [lindex [punk::ansi::colour::contrast_pair {*}[split $rgbdash -]] 0] {;}] - } - default { - set rgb [tcl::string::map { - ;} $rgbdash] - } - } - lappend t "48;2;$rgb" - } else { - puts stderr "ansi Tk background colour unmatched: '$i'" - } - } - default { - if {[tcl::string::is integer -strict $i] || [tcl::string::first ";" $i] > 0} { - lappend t $i - } elseif {[tcl::string::first : $i] > 0} { - lappend e $i - } else { - puts stderr "punk::ansi::a+ ansi name unmatched: '$i' in call 'a+ $args' Perhaps missing prefix? e.g web- x11- tk- term- rgb# rgb-" - } - } - } - } - - #the performance penalty must not be placed on the standard colour_enabled path. - #This is punk. Colour is the happy path despite the costs. - #The no_color users will still get a performance boost from shorter string processing if that's one of their motivations. - #As no_color doesn't strip all ansi - the motivation for it should not generally be - if {$colour_disabled && !$forcecolour} { - set tkeep [list] - foreach code $t { - switch -- $code { - 0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 { - #SGR underline and other non colour effects - lappend tkeep $code - } - } - } - set t $tkeep - set ekeep [list] - foreach code $e { - switch -- $code { - 4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 { - lappend ekeep $code - } - } - } - set e $ekeep - } - - # \033 - octal. equivalently \x1b in hex which is more common in documentation - if {![llength $t]} { - if {![llength $e]} { - set result "" ;# a+ nonexistent should return nothing rather than a reset ( \033\[\;m is a reset even without explicit zero(s)) - } else { - set result "\x1b\[[join $e {;}]m" - } - } else { - if {![llength $e]} { - set result "\x1b\[[join $t {;}]m" - } else { - set result "\x1b\[[join $t {;}]m\x1b\[[join $e {;}]m" - } - } - tcl::dict::set sgr_cache $cache_key $result - return $result - } - - set SGR_samples [dict create] - foreach k [dict keys $SGR_map] { - #indent of 1 space is important for clarity in i -return string a+ output - dict set SGR_samples $k " [punk::ansi::a+ $k]sample\x1b\[m" - } - set SGR_help\ - {SGR code from the list below, or an integer corresponding to the code e.g 31 = red. - A leading capital letter indicates a codename applies to the background colour. - Other accepted codes are: - term- Term- foreground/background where int is 0-255 terminal color - term- Term- foreground/background - - web- Web- - - x11- X11- - - tk- Tk- - - rgb--- Rgb--- foreground/background where are the - 0-255 int values for red, green and blue. - rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 - - The acceptable values for colours can be queried using - punk::ansi::a? term - punk::ansi::a? web - punk::ansi::a? x11 - punk::ansi::a? tk - - Example to set foreground red and background cyan followed by a reset: - set str \"[a+ red Cyan]sample text[a]\" - } - lappend PUNKARGS [list { - @id -id ::punk::ansi::a+ - @cmd -name "punk::ansi::a+" -help\ - "Returns an ANSI sgr escape sequence based on the list of supplied codes. - Unlike punk::ansi::a - it is not prefixed with an ANSI reset. - " - @values -min 0 -max -1 - } [string map [list %choices% [dict keys $SGR_map] %choicelabels% $SGR_samples %SGR_help% $SGR_help] { - code -type string -optional 1 -multiple 1 -choices {%choices%}\ - -choicelabels {%choicelabels%}\ - -choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\ - "%SGR_help%" - }]] - - lappend PUNKARGS [list { - @id -id ::punk::ansi::a - @cmd -name "punk::ansi::a" -help\ - "Returns an ANSI sgr escape sequence based on the list of supplied codes. - Unlike punk::ansi::a+ - it is prefixed with an ANSI reset. - " - @values -min 0 -max -1 - } [string map [list %choices% [dict keys $SGR_map] %choicelabels% $SGR_samples %SGR_help% $SGR_help] { - code -type string -optional 1 -multiple 1 -choices {%choices%}\ - -choicelabels {%choicelabels%}\ - -choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\ - "%SGR_help%" - }]] - - proc a {args} { - #*** !doctools - #[call [fun a] [opt {ansicode...}]] - #[para]Returns the ansi code to reset any current settings and apply those from the supplied list - #[para] by calling punk::ansi::a with no arguments - the result is a reset to plain text - #[para] e.g to set foreground red and bold - #[para]punk::ansi::a red bold - #[para]to set background red - #[para]punk::ansi::a Red - #[para]see [cmd punk::ansi::a?] to display a list of codes - - #It's important to put the functionname in the cache-key because a and a+ return slightly different results - variable sgr_cache - set cache_key "a $args" - if {[tcl::dict::exists $sgr_cache $cache_key]} { - return [tcl::dict::get $sgr_cache $cache_key] - } - - #don't disable ansi here. - #we want this to be available to call even if ansi is off - variable WEB_colour_map - variable TERM_colour_map - variable TK_colour_map_lookup ;#Tk accepts lowercase versions of colours even though some colours are documented with casing - - set colour_disabled 0 - #whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache -action clear - if {[tcl::info::exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { - set colour_disabled 1 - } - #allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything. - set forcecolour 0 - set fcpos [lsearch $args "force*"] ;#allow forcecolor forcecolour - if {$fcpos >=0} { - set forcecolour 1 - set args [lremove $args $fcpos] - } - - set t [list] - set e [list] ;#extended codes will suppress standard SGR colours and attributes if merged in same escape sequence - foreach i $args { - #set f4 [tcl::string::range $i 0 3] - set pfx [lindex [split $i "-# "] 0] - switch -- $pfx { - web { - #variable WEB_colour_map - #upvar ::punk::ansi::WEB_colour_map WEB_colour_map - #foreground web colour - set cname [tcl::string::tolower [tcl::string::range $i 4 end]] - if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] - set rgb [tcl::string::map { - ;} $rgbdash] - lappend t "38;2;$rgb" - } else { - puts stderr "ansi web colour unmatched: '$i' in call 'a $args'" - } - } - Web - WEB { - #variable WEB_colour_map - #upvar ::punk::ansi::WEB_colour_map WEB_colour_map - #background web colour - set cname [tcl::string::tolower [tcl::string::range $i 4 end]] - if {[tcl::dict::exists $WEB_colour_map $cname]} { - lappend t "48;2;[tcl::string::map {- ;} [tcl::dict::get $WEB_colour_map $cname]]" - } else { - puts stderr "ansi Web colour unmatched: '$i' in call 'a $args'" - } - } - reset {lappend t 0} - bold {lappend t 1} - dim {lappend t 2} - blink {lappend t 5} - fastblink {lappend t 6} - noblink {lappend t 25} - hide {lappend t 8} - normal {lappend t 22} - underline { - lappend t 4 ;#underline - } - underlinedefault {lappend t 59} - underextendedoff { - #lremove any existing 4:1 etc - #use of struct::set with critcl is fast, but will reorder e (with differences depending on tcl vs critcl) - #set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] - set e [punk::lib::ldiff $e [list 4:1 4:2 4:3 4:4 4:5]] - lappend e 4:0 - } - undersingle { - lappend e 4:1 - } - underdouble { - lappend e 4:2 - } - undercurly - undercurl { - lappend e 4:3 - } - underdotted - underdot { - lappend e 4:4 - } - underdashed - underdash { - lappend e 4:5 - } - doubleunderline {lappend t 21} - nounderline { - lappend t 24 ;#nounderline - #set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] - lappend e 4:0 - } - strike {lappend t 9} - nostrike {lappend t 29} - italic {lappend t 3} - noitalic {lappend t 23} - reverse {lappend t 7} - noreverse {lappend t 27} - defaultfg {lappend t 39} - defaultbg {lappend t 49} - defaultund { - lappend t 59 - } - nohide {lappend t 28} - overline {lappend t 53} - nooverline {lappend t 55} - frame {lappend t 51} - framecircle {lappend t 52} - noframe {lappend t 54} - black {lappend t 30} - red {lappend t 31} - green {lappend t 32} - yellow {lappend t 33} - blue {lappend t 34} - purple {lappend t 35} - cyan {lappend t 36} - white {lappend t 37} - Black {lappend t 40} - Red {lappend t 41} - Green {lappend t 42} - Yellow {lappend t 43} - Blue {lappend t 44} - Purple {lappend t 45} - Cyan {lappend t 46} - White {lappend t 47} - brightblack {lappend t 90} - brightred {lappend t 91} - brightgreen {lappend t 92} - brightyellow {lappend t 93} - brightblue {lappend t 94} - brightpurple {lappend t 95} - brightcyan {lappend t 96} - brightwhite {lappend t 97} - Brightblack {lappend t 100} - Brightred {lappend t 101} - Brightgreen {lappend t 102} - Brightyellow {lappend t 103} - Brightblue {lappend t 104} - Brightpurple {lappend t 105} - Brightcyan {lappend t 106} - Brightwhite {lappend t 107} - term { - #variable TERM_colour_map - #256 colour foreground by Xterm name or by integer - #name is xterm name or colour index from 0 - 255 - set cc [tcl::string::tolower [tcl::string::range $i 5 end]] - if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend t "38;5;$cc" - } else { - if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" - } else { - puts stderr "ansi term colour unmatched: '$i' in call 'a $args'" - } - } - } - Term - TERM { - #variable TERM_colour_map - #256 colour background by Xterm name or by integer - set cc [tcl::string::tolower [tcl::string::range $i 5 end]] - if {[tcl::string::is integer -strict $cc] && $cc < 256} { - lappend t "48;5;$cc" - } else { - if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" - } else { - puts stderr "ansi Term colour unmatched: '$i' in call 'a $args'" - } - } - } - rgb { - set utype [string index $i 3] - if {$utype eq "-"} { - #decimal rgb foreground - #form: rgb-xxx-xxx-xxx - set rgbspec [tcl::string::range $i 4 end] - set rgb [tcl::string::map [list - {;} , {;}] $rgbspec] - lappend t "38;2;$rgb" - } elseif {$utype eq "#"} { - #hex rgb foreground - set hex6 [tcl::string::range $i 4 end] - set rgb [join [::scan $hex6 %2X%2X%2X] {;}] - lappend t "38;2;$rgb" - } else { - puts stderr "ansi rgb foreground colour unmatched: '$i' in call 'a $args'" - } - } - Rgb - RGB { - set utype [string index $i 3] - if {$utype eq "-"} { - #decimal rgb background - set rgbspec [tcl::string::range $i 4 end] - set rgb [tcl::string::map [list - {;} , {;}] $rgbspec] - lappend t "48;2;$rgb" - } elseif {$utype eq "#"} { - #hex rgb background - set hex6 [tcl::string::range $i 4 end] - set rgb [join [::scan $hex6 %2X%2X%2X] {;}] - lappend t "48;2;$rgb" - } else { - puts stderr "ansi Rgb background colour unmatched: '$i' in call 'a $args'" - } - } - und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 {} - und { - set utype [string index $i 3] - if {$utype eq "-"} { - #decimal rgb underline - #form: und-xxx-xxx-xxx - set rgbspec [tcl::string::range $i 4 end] - set rgb [tcl::string::map [list - {:} , {:}] $rgbspec] - lappend e "58:2::$rgb" - } elseif {$utype eq "#"} { - #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators - set hex6 [tcl::string::range $i 4 end] - set rgb [join [::scan $hex6 %2X%2X%2X] {:}] - lappend e "58:2::$rgb" - } else { - puts stderr "ansi underline colour unmatched: '$i' in call 'a $args'" - } - } - undt { - #variable TERM_colour_map - #256 colour underline by Xterm name or by integer - #name is xterm name or colour index from 0 - 255 - #undt-<0-255> or undt- - set cc [tcl::string::tolower [tcl::string::range $i 5 end]] - if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend e "58:5:$cc" - } else { - if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" - } else { - puts stderr "ansi term underline colour unmatched: '$i' in call 'a $args'" - } - } - } - x11 { - variable X11_colour_map - #foreground X11 names - set cname [tcl::string::tolower [tcl::string::range $i 4 end]] - if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] - set rgb [tcl::string::map [list - {;}] $rgbdash] - lappend t "38;2;$rgb" - } else { - puts stderr "ansi x11 foreground colour unmatched: '$i'" - } - } - X11 { - variable X11_colour_map - #background X11 names - set cname [tcl::string::tolower [tcl::string::range $i 4 end]] - if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] - set rgb [tcl::string::map [list - {;}] $rgbdash] - lappend t "48;2;$rgb" - } else { - puts stderr "ansi X11 background colour unmatched: '$i'" - } - } - tk { - variable TK_colour_map_lookup - #foreground tk names - set cname [tcl::string::tolower [tcl::string::range $i 3 end]] - if {[tcl::dict::exists $TK_colour_map_lookup $cname]} { - set rgbdash [tcl::dict::get $TK_colour_map_lookup $cname] - set rgb [tcl::string::map [list - {;}] $rgbdash] - lappend t "38;2;$rgb" - } else { - puts stderr "ansi tk foreground colour unmatched: '$i'" - } - } - Tk - TK { - variable TK_colour_map_lookup - #background X11 names - set cname [tcl::string::tolower [tcl::string::range $i 3 end]] - if {[tcl::dict::exists $TK_colour_map_lookup $cname]} { - set rgbdash [tcl::dict::get $TK_colour_map_lookup $cname] - set rgb [tcl::string::map [list - {;}] $rgbdash] - lappend t "48;2;$rgb" - } else { - puts stderr "ansi Tk background colour unmatched: '$i'" - } - } - default { - if {[tcl::string::is integer -strict $i] || [tcl::string::first ";" $i] > 0} { - lappend t $i - } elseif {[tcl::string::first : $i] > 0} { - lappend e $i - } else { - puts stderr "punk::ansi::a ansi name unmatched: '$i' in call 'a $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-" - } - } - } - } - - if {$colour_disabled && !$forcecolour} { - set tkeep [list] - foreach code $t { - switch -- $code { - 0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 { - #SGR underline and other non colour effects - lappend tkeep $code - } - } - } - set t $tkeep - set ekeep [list] - foreach code $e { - switch -- $code { - 4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 { - lappend ekeep $code - } - } - } - set e $ekeep - } - - # \033 - octal. equivalently \x1b in hex which is more common in documentation - # empty list [a] should do reset - same for [a nonexistant] - # explicit reset at beginning of parameter list for a= (as opposed to a+) - set t [linsert $t[unset t] 0 0] - if {![llength $e]} { - set result "\x1b\[[join $t {;}]m" - } else { - set result "\x1b\[[join $t {;}]m\x1b\[[join $e {;}]m" - } - tcl::dict::set sgr_cache $cache_key $result - return $result - } - - lappend PUNKARGS [list { - @id -id ::punk::ansi::ansiwrap - @cmd -name punk::ansi::ansiwrap\ - -summary\ - "Wrap a string with ANSI codes applied when not overridden by ANSI in the source string."\ - -help\ - {Wrap a string with ANSI codes from - supplied codelist(s) followed by trailing - ANSI reset. The wrapping is done such that - after every reset in the supplied text, the - default goes back to the supplied codelist. - e.g1 in the following - ansiwrap red bold "rrr[a+ green]ggg[a]rrr" - both strings rrr will be red & bold - - e.g2 bolding and underlining specific text whilst dimming the rest - ansiwrap dim [string map [list test [ansiwrap bold underline test]] "A test string"] - - e.g3 reverse render a complex ansi substring - ansiwrap reverse [textblock::periodic] - - Codes are numbers or strings as indicated - in the output of the colour information - function: punk::ansi::a? - - No leading reset is applied - so when - placing resultant text, any existing - SGR codes that aren't overridden may - still take effect. - - For finer control use the a+ and a - functions eg - set x "[a+ red]text [a+ bold]etc[a]" - } - @leaders -min 0 -max -1 - codelist -multiple 1 -default {} -type list -help\ - "ANSI names/ints as understood by 'a?' - (Not actual ANSI as output by a+) - These can be supplied individually or - as a list or lists" - @opts - -rawansi -type ansi -default "" - -resetcodes -type list -default {reset} - -rawresets -type ansi -default "" - -overridecodes -type list -default {} - -rawoverrides -type ansi -default "" - @values -min 1 -max 1 - text -type any -help\ - "String to wrap with ANSI (SGR)" - }] - proc ansiwrap {args} { - if {[llength $args] < 1} { - #throw to args::parse to get friendly error/usage display - punk::args::parse $args withid ::punk::ansi::ansiwrap - return - } - #we know there are no valid codes that start with - - if {[lsearch [lrange $args 0 end-1] -*] == -1} { - #no opts - skip args parser - #maint: keep defaults in sync with definition above - set codelists $args - set text [lpop codelists] - set R [a] ;#plain ansi reset (equiv of default "reset") - set rawansi "" - set rawresets "" - set overrides "" - set rawoverrides "" - } else { - set argd [punk::args::parse $args withid ::punk::ansi::ansiwrap] - lassign [dict values $argd] leaders opts values received solos - set codelists [dict get $leaders codelist] - set text [dict get $values text] - set rawansi [dict get $opts -rawansi] - set R [a+ {*}[dict get $opts -resetcodes]] - set rawresets [dict get $opts -rawresets] - set overrides [punk::ansi::ta::get_codes_single [a+ {*}[dict get $opts -overridecodes]]] - set rawoverrides [punk::ansi::ta::get_codes_single [dict get $opts -rawoverrides]] - } - - #note that the result of any sgr_merge or sgr_merge_singles is not necessarily a single Ansi escape sequence. - #there can be SGR unmergeables (due to enhanced underlines) as well as non SGR codes - set codes [concat {*}$codelists] ;#flatten - set base [a+ {*}$codes] - set baselist [punk::ansi::ta::get_codes_single $base] - if {$rawansi ne ""} { - set rawcodes [punk::ansi::ta::get_codes_single $rawansi] ;#caller may have supplied as [a+ xxx][a+ yyy] - set base [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$rawcodes]] - set baselist [punk::ansi::ta::get_codes_single $base] - } - if {$rawresets ne ""} { - set rawresetcodes [punk::ansi::ta::get_codes_single $rawresets] - set Rcodes [punk::ansi::ta::get_codes_single $R] - set R [punk::ansi::codetype::sgr_merge_singles [list {*}$Rcodes {*}$rawresetcodes]] - } - - if {$rawoverrides ne ""} { - set rawoverridecodes [punk::ansi::ta::get_codes_single $rawoverrides] - set overrides [list {*}$overrides {*}$rawoverridecodes] - } - - set codestack [list] - if {[punk::ansi::ta::detectcode $text]} { - set emit "" - #set parts [punk::ansi::ta::split_codes $text] - set parts [punk::ansi::ta::split_codes_single $text] - set prevcode "" - foreach {pt code} $parts { - switch -- [llength $codestack] { - 0 { - append emit $base $pt $R - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} { - append emit $base $pt $R - set codestack [list] - } else { - #append emit [lindex $o_codestack 0]$pt - append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$codestack {*}$overrides]] $pt $R - } - } - default { - append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$codestack {*}$overrides]] $pt $R - } - } - #parts ends on a pt - last code always empty string - if {$code ne ""} { - set prevcode $code - set c1c2 [tcl::string::range $code 0 1] - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\( 7GFX\ - ] $c1c2] 0 3] - switch -- $leadernorm { - 7CSI - 8CSI { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #todo - make caching is_sgr method - set dup_posns [lsearch -all -exact $codestack $code] - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } else { - #jjtest - append emit $code - } - } - 7GFX { - switch -- [tcl::string::index $code 2] { - "0" { - set o_gx_state on - } - "B" { - set o_gx_state off - } - } - #jjtest - append emit $code - } - default { - #other ansi codes - #jjtest - append emit $code - } - } - #jjtest - #append emit $code - } else { - #jjtest - #code is only empty when processing final pt - if {$pt eq ""} { - append emit $prevcode - } - } - } - return [append emit $R] - } else { - return $base$text$R - } - } - proc ansiwrap_raw {rawansi rawresets rawoverrides text} { - set codelists "" - set R "" - set overrides "" - #note that the result of any sgr_merge or sgr_merge_singles is not necessarily a single Ansi escape sequence. - #there can be SGR unmergeables (due to enhanced underlines) as well as non SGR codes - set codes [concat {*}$codelists] ;#flatten - set base [a+ {*}$codes] - set baselist [punk::ansi::ta::get_codes_single $base] - if {$rawansi ne ""} { - set rawcodes [punk::ansi::ta::get_codes_single $rawansi] ;#caller may have supplied as [a+ xxx][a+ yyy] - set base [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$rawcodes]] - set baselist [punk::ansi::ta::get_codes_single $base] - } - if {$rawresets ne ""} { - set rawresetcodes [punk::ansi::ta::get_codes_single $rawresets] - set Rcodes [punk::ansi::ta::get_codes_single $R] - set R [punk::ansi::codetype::sgr_merge_singles [list {*}$Rcodes {*}$rawresetcodes]] - } - - if {$rawoverrides ne ""} { - set rawoverridecodes [punk::ansi::ta::get_codes_single $rawoverrides] - set overrides [list {*}$overrides {*}$rawoverridecodes] - } - - set codestack [list] - if {[punk::ansi::ta::detectcode $text]} { - set emit "" - #set parts [punk::ansi::ta::split_codes $text] - set parts [punk::ansi::ta::split_codes_single $text] - set prevcode "" - foreach {pt code} $parts { - switch -- [llength $codestack] { - 0 { - append emit $base $pt $R - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} { - append emit $base $pt $R - set codestack [list] - } else { - #append emit [lindex $o_codestack 0]$pt - append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$codestack {*}$overrides]] $pt $R - } - } - default { - append emit [punk::ansi::codetype::sgr_merge_singles [list {*}$baselist {*}$codestack {*}$overrides]] $pt $R - } - } - #parts ends on a pt - last code always empty string - if {$code ne ""} { - set prevcode $code - set c1c2 [tcl::string::range $code 0 1] - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\( 7GFX\ - ] $c1c2] 0 3] - switch -- $leadernorm { - 7CSI - 8CSI { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #todo - make caching is_sgr method - set dup_posns [lsearch -all -exact $codestack $code] - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } else { - #jjtest - apend emit $code - } - } - 7GFX { - switch -- [tcl::string::index $code 2] { - "0" { - set o_gx_state on - } - "B" { - set o_gx_state off - } - } - #jjtest - append emit $code - } - default { - #other ansi codes - #jjtest - append emit $code - } - } - #jjtest - #append emit $code - } else { - #jjtest - #code is only empty when processing final pt - if {$pt eq ""} { - append emit $prevcode - } - } - } - return [append emit $R] - } else { - return $base$text$R - } - - } - proc ansiwrap_naive {codes text} { - return [a_ {*}$codes]$text[a] - } - - #a silly trick... temporary? probably - todo - tests and work on sgr_merge + sgr_merge_singles before relying on this - #when we use sgr_merge_singles on a 'single' containing a non SGR code e.g [5h (inverse) it puts this code at the end of the list - #furthermore - it carries any SGR codes along with it (Can/should we rely on this behaviour??? probably not) REVIEW - #P% ansistring VIEW $s1 - #- ␛[31m␛[?5h - #P% ansistring VIEW [punk::ansi::codetype::sgr_merge_singles [list $s1 [a+ cyan]]] - #- ␛[36m␛[31m␛[?5h - #P% ansistring VIEW [punk::ansi::codetype::sgr_merge [list $s1 [a+ cyan]]] - #- ␛[36m␛[?5h - #we can use this trick to override background and/or foreground colours using ansiwrap - which uses sgr_merge_singles - #Note - this trick is not composable - e.g ansioverride Red [ansiioverride Green [textblock::periodic]] doesn't work as expected. - proc ansioverride2 {args} { - set text [lindex $args end] - set codes [lrange $args 0 end-1] - ansiwrap {*}$codes -rawansi [punk::ansi::enable_inverse] -rawresets [punk::ansi::disable_inverse] $text - } - proc ansireverse {text} { - ansioverride2 normal reverse $text - } - - proc get_code_name {code} { - #*** !doctools - #[call [fun get_code_name] [arg code]] - #[para]for example - #[para] get_code_name red will return 31 - #[para] get_code_name 31 will return red - variable SGR_map - set res [list] - foreach i [split $code ";"] { - set ix [lsearch -exact $SGR_map $i] - if {[tcl::string::is digit -strict $code]} { - if {$ix>-1} {lappend res [lindex $SGR_map [incr ix -1]]} - } else { - #reverse lookup code from name - if {$ix>-1} {lappend res [lindex $SGR_map [incr ix]]} - } - } - set res - } - proc reset {} { - #*** !doctools - #[call [fun reset]] - #[para]reset console - return "\x1bc" - } - proc reset_soft {} { - #*** !doctools - #[call [fun reset_soft]] - return \x1b\[!p - } - proc SYN {} { - #syn seems to disable alternate graphics mode temporarily on modern terminals - return \016 - } - proc ETB {} { - #This is a form of soft reset for the state where a SYN was sent - re-enabling altg processing - return \017 - } - proc reset_colour {} { - #*** !doctools - #[call [fun reset_colour]] - #[para]reset colour only - return "\x1b\[0m" - } - - # -- --- --- --- --- - proc clear {} { - #*** !doctools - #[call [fun clear]] - return "\033\[2J" - } - proc clear_above {} { - #*** !doctools - #[call [fun clear_above]] - return \033\[1J - } - proc clear_below {} { - #*** !doctools - #[call [fun clear_below]] - return \033\[0J - } - - proc clear_all {} { - # - doesn't work?? - return \033\[3J - } - #see also erase_ functions - # -- --- --- --- --- - - proc cursor_on {} { - #*** !doctools - #[call [fun cursor_on]] - return "\033\[?25h" - } - proc cursor_off {} { - #*** !doctools - #[call [fun cursor_off]] - return "\033\[?25l" - } - proc cursor_on_vt52 {} { - return \x1be - } - proc cursor_off_vt52 {} { - return \x1bf - } - - # REVIEW - osc8 replays etc for split lines? - textblock - #Hyperlinks (a.k.a. HTML-like anchors) in terminal emulators https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda - #the 'id' parameter logically connects split hyperlinks - #per interp. Rather than try to avoid collisions using something like 'info cmdcount' we will use a simple counter. - #To stop multiple hyperlinks from having ids inadvertently collide - we should do some id mangling/prefixing based on the terminal/window etc - #It is better to use a simple counter with high likelihood of collision so we are more likely to detect problems with ids than to make it more intermittent by using ids that collide only 'rarely' - variable hyperlinkcounter - set hyperlinkcounter 0 - - - proc hyperlink {uri {display ""}} { - variable hyperlinkcounter - if {$display eq ""} { - set display $uri - } - set uri [punk::ansi::ansistripraw $uri] - #limit uri length we emit based on common limits in other terminals - if {[string length $uri] > 2083} { - error "punk::ansi::hyperlink uri too long: limit 2083" - } - set params "id=punkansi-[incr hyperlinkcounter]" ;#todo e.g id=xyz123:foo=bar:baz=quux - set open "\x1b\]8\;$params\;$uri\x1b\\" - set close "\x1b\]8\;\;\x1b\\" - return ${open}${display}${close} - } - - #on windows terminal at least, both uri and id of 2 separated hyperlinks need to match for the hover highlighting to act as a unit. - proc hyperlink_open {uri {id ""}} { - if {$id eq ""} { - set id punkansi-[incr hyperlinkcounter] - } - set uri [punk::ansi::ansistripraw $uri] - if {[string length $uri] > 2083} { - error "punk::ansi::hyperlink uri too long: limit 2083" - } - set id [string map {: . {;} ,} $id] ;#avoid some likely problematic ids. TODO - review, restrict further. - set params "id=$id" - return "\x1b\]8\;$params\;$uri\x1b\\" - } - #It should be ok to close even if no currently active hyperlink (e.g can be used to cleanup if something awry) - proc hyperlink_close {} { - return "\x1b\]8\;\;\x1b\\" - } - - # -- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::punk::ansi::move - @cmd -name punk::ansi::move -help\ - {Return an ANSI sequence to move cursor to row,col - (aka: cursor home) - - Sequence is of the form: - \x1b[;H - (CSI row ; col H) - This sequence will not be understood by old vt52 - terminals. see also vt52_move. - } - @values -min 2 -max 2 - row -type integer -help\ - "row number - starting at 1" - col -type integer -help\ - "column number - starting at 1" - }] - proc move {row col} { - #*** !doctools - #[call [fun move] [arg row] [arg col]] - #[para]Return an ansi sequence to move to row,col - #[para]aka cursor home - return \033\[${row}\;${col}H - } - #NOTE vt52 uses ESC Y line column - # where line and column are ascii codes whose values are +31 - # vt52 can be entered/exited via escapes - # This means we probably need to to wrap enter/exit vt52 and keep this state - as we don't have a standard way to query for terminal type - # (vt52 supports ESC Z (obs DECID) - but vt100 sometimes? doesn't - and querying at each output would be slow anyway, even if there was a common query :/ ) - #ESC\[c - is more modern equiv of DECID - - lappend PUNKARGS [list { - @id -id ::punk::ansi::vt52move - @cmd -name punk::ansi::vt52move -help\ - {Return a VT52 sequence to move cursor to row,col - (aka: cursor home) - - Sequence is of the form: - ESCY - This sequence will generally not be understood by terminals - that are not in vt52 mode (e.g DECANM unset). - } - @values -min 2 -max 2 - row -type integer -help\ - "row number - starting at 1" - col -type integer -help\ - "column number - starting at 1" - }] - proc vt52move {row col} { - #test - set r [format %c [expr {$row + 31}]] - set c [format %c [expr {$col + 31}]] - return \x1bY${r}${c} - } - proc vt52color {int} { - if {[string is integer -strict $int]} { - if {$int < 0 || $int > 15} { - error "vt52color unsupported - only 0 to 15 available" - } - } - set char [format %c [expr {$int + 31}]] - return \x1bb${char} - } - proc move_emit {row col data args} { - #*** !doctools - #[call [fun move_emit] [arg row] [arg col] [arg data] [opt {row col data...}]] - #[para]Return an ansi string representing a move to row col with data appended - #[para]row col data can be repeated any number of times to return a string representing the output of the data elements at all those points - #[para]Compare to punk::console::move_emit which calls this function - but writes it to stdout - #[para]punk::console::move_emit_return will also return the cursor to the original position - #[para]There is no punk::ansi::move_emit_return because in a standard console there is no ansi string which can represent a jump back to starting position. - #[para]There is an ansi code to write the current cursor position to stdin (which will generally display on the console) - this is not quite the same thing. - #[para]punk::console::move_emit_return does it by emitting that code and starting a loop to read stdin - #[para]punk::ansi could implement a move_emit_return using the punk::console mechanism - but the resulting string would capture the cursor position at the time the string is built - which is not necessarily when the string is used. - #[para]The following example shows how to do this manually, emitting the string blah at screen position 10,10 and emitting DONE back at the line we started: - #[para][example {punk::ansi::move_emit 10 10 blah {*}[punk::console::get_cursor_pos_list] DONE}] - #[para]A string created by any move_emit_return for punk::ansi would not behave in an intuitive manner compared to other punk::ansi move functions - so is deliberately omitted. - - set out "" - if {$row eq "this"} { - append out \033\[\;${col}G$data - } else { - append out \033\[${row}\;${col}H$data - } - foreach {row col data} $args { - if {$row eq "this"} { - append out \033\[\;${col}G$data - } else { - append out \033\[${row}\;${col}H$data - } - } - return $out - } - proc vt52move_emit {row col data args} { - #Todo - G code? - set out "" - if {$row eq "this"} { - #append out \033\[\;${col}G$data - append out [vt52move_column $col]$data - } else { - #append out \033\[${row}\;${col}H$data - append out [vt52move $row $col]$data - } - foreach {row col data} $args { - if {$row eq "this"} { - append out [vt52move_column $col]$data - #append out \033\[\;${col}G$data - } else { - #append out \033\[${row}\;${col}H$data - append out [vt52move $row $col]$data - } - } - return $out - } - proc move_emitblock {row col textblock} { - #*** !doctools - #[call [fun move_emitblock] [arg row] [arg col] [arg textblock]] - set commands "" - foreach ln [split $textblock \n] { - append commands [punk::ansi::move_emit $row $col $ln] - incr row - } - return $commands - } - proc vt52move_emitblock {row col textblock} { - #*** !doctools - #[call [fun move_emitblock] [arg row] [arg col] [arg textblock]] - set commands "" - foreach ln [split $textblock \n] { - append commands [punk::ansi::vt52move_emit $row $col $ln] - incr row - } - return $commands - } - proc move_forward {{n 1}} { - #*** !doctools - #[call [fun move_forward] [arg n]] - return \033\[${n}C - } - proc vt52move_forward {{n 1}} { - return [string repeat \x1bC $n] - } - proc move_back {{n 1}} { - #*** !doctools - #[call [fun move_back] [arg n]] - return \033\[${n}D - } - proc vt52move_back {{n 1}} { - return [string repeat \x1bD $n] - } - proc move_up {{n 1}} { - #*** !doctools - #[call [fun move_up] [arg n]] - return \033\[${n}A - } - proc vt52move_up {{n 1}} { - return [string repeat \x1bA $n] - } - proc move_down {{n 1}} { - #*** !doctools - #[call [fun move_down] [arg n]] - return \033\[${n}B - } - proc vt52move_down {{n 1}} { - return [string repeat \x1bB $n] - } - proc move_column {col} { - #*** !doctools - #[call [fun move_column] [arg col]] - return \x1b\[${col}G - } - proc vt52move_column {col} { - #This is a bit of a fudge - as there is no command to move to a specific column. - #without tracking state - we settle for moving back enough times to ensure we're at column 1 - and then move forward. - #inefficient - but will have to do I guess. - #review - max term width vt52? env var LINES and env var COLUMNS ? - # also ESC R CR - set window size - set back [string repeat \x1bD 132] - set fwd [string repeat \x1bC [expr {$col - 1}]] - return $back$fwd - } - proc move_row {row} { - #*** !doctools - #[call [fun move_row] [arg row]] - #[para]VPA - Vertical Line Position Absolute - return \x1b\[${row}d - } - # -- --- --- --- --- - - proc cursor_save {} { - #*** !doctools - #[call [fun cursor_save]] - #[para] equivalent term::ansi::code::ctrl::sc - #[para] This is the ANSI/SCO cursor save as opposed to the DECSC version - #[para] On many terminals either will work - but cursor_save_dec is shorter and perhaps more widely supported - return \x1b\[s - } - proc cursor_restore {} { - #*** !doctools - #[call [fun cursor_restore]] - #[para] equivalent term::ansi::code::ctrl::rc - #[para] ANSI/SCO - see also cursor_restore_dec for the DECRC version - return \x1b\[u - } - proc cursor_save_dec {} { - #*** !doctools - #[call [fun cursor_save_dec]] - #[para] equivalent term::ansi::code::ctrl::sca - #[para] DECSC - return \x1b7 - } - proc cursor_restore_dec {} { - #*** !doctools - #[call [fun cursor_restore_attributes]] - #[para] equivalent term::ansi::code::ctrl::rca - #[para] DECRC - return \x1b8 - } - proc cursor_save_vt52 {} { - return \x1bj - } - proc cursor_restore_vt52 {} { - return \x1bk - } - - # -- --- --- --- --- - #CRM Show Control Character Mode - proc enable_crm {} { - return \x1b\[3h - } - proc disable_crm {} { - return \x1b\[3l - } - - #DECSNM - #Note this can invert the enclosed section including any already reversed by SGR 7 - depending on terminal support. - #e.g - #set test [a+ reverse]aaa[a+ noreverse]bbb - # - $test above can't just be reversed by putting another [a+ reverse] in front of it. - # - but the following will work (even if underlying terminal doesn't support ?5 sequences) - #overtype::renderspace -width 20 [enable_inverse]$test - proc enable_inverse {} { - return \x1b\[?5h - } - proc disable_inverse {} { - return \x1b\[?5l - } - - - #DECAWM - automatic line wrapping - proc enable_line_wrap {} { - #*** !doctools - #[call [fun enable_line_wrap]] - #[para] enable automatic line wrapping when characters entered beyond rightmost column - #[para] This will also allow forward movements to move to subsequent lines - #[para] This is DECAWM - and is the same sequence output by 'tput smam' - return \x1b\[?7h - } - proc disable_line_wrap {} { - #*** !doctools - #[call [fun disable_line_wrap]] - #[para] disable automatic line wrapping - #[para] reset DECAWM - same sequence output by 'tput rmam' - #tput rmam - return \x1b\[?7l - } - - - proc query_mode_line_wrap {} { - #*** !doctools - #[call [fun query_mode_line_wrap]] - #[para] DECRQM to query line-wrap state - #[para] The punk::ansi::query_mode_ functions just emit the ansi query sequence. - return \x1b\[?7\$p - } - #DECRPM responses e.g: - # \x1b\[?7\;1\$y - # \x1b\[?7\;2\$y - #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) - - #https://wiki.tau.garden/dec-modes/ - #(DEC,xterm,contour,mintty,kitty etc) - #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking - - #names for other alt_screen mechanismk: 1047,1048 vs 1049? - #variable decmode_names [dict create\ - # DECANM 2\ - # origin 6\ - # DECCOLM 3\ - # line_wrap 7\ - # LNM 20\ - # alt_screen 1049\ - # grapheme_clusters 2027\ - # bracketed_paste 2004\ - # mouse_sgr 1006\ - # mouse_urxvt 1015\ - # mouse_sgr_pixel 1016\ - #] - variable decmode_data { - 1 { - {origin DEC description "DECCKM - Cursor Keys Mode" names {DECCKM cursor_keys}} - } - 2 { - {origin DEC description "DECANM - ANSI/VT52 Mode" names {DECANM} note { -Disable to turn on VT52 emulation. -In VT52 mode - use \x1b< to exit. - } - } - } - 3 { - {origin DEC description "DECCOLM - Column" names {DECCOLM}} - } - 4 { - {origin DEC description "DECSCLM - Scrolling" names {DECSCLM}} - } - 5 { - {origin DEC description "DECSCNM - Screen Mode (light or dark screen)" names {DECSNM lightmode}} - } - 7 { - {origin DEC description "DECAWM - Auto Wrap Mode" names {DECAWM line_wrap}} - } - 9 { - {origin "xterm" description "X10 compatibility mouse" names {SET_X10_MOUSE mouse_tracking} note { -Escape sequence on button press only. -CSI M CbCxCy (6 chars) -Coords limited to 223 (=255 - 32) - } - } - {origin DEC description "DECINLM - Interlace Mode (obsolete?)" names {DECINLM}} - } - 20 { - {origin DEC description "LNM - Line Feed/New Line Mode" names {LNM} note { -For terminals that support LNM, the default is off -meaning a lone CR respresents the character emitted -when enter is pushed. Turning LNM on would mean that -CR LF is sent when hitting enter. This feature is -not commonly supported, and the default will normally -be as if this was off - ie lone CR. - } - } - } - 25 { - {origin DEC description "DECTCEM - Text Cursor Enable Mode" names {DECTCEM cursor_enable}} - } - 47 { - {origin xterm description "xterm alternate buffer" names {xterm_altbuf}} - {origin DEC description "DECGRPM - Graphics Rotated Print Mode (obsolete?)" names {DECGRPM}} - } - 66 { - {origin DEC description "DECNKM - Numeric Keypad Mode" names {DECNKM}} - } - 1000 { - {origin "xterm" description "VT200 compatibility mouse" names {SET_VT200_MOUSE} note { -Escape sequence on both button press and release. -CSI M CbCxCy - } - } - } - 1004 { - {origin "xterm" description "Send FocusIn/FocusOut events" names {mouse_focus_event}} - } - 1005 { - {origin "xterm" description "Enable UTF-8 Mouse Mode" names {mouse_utf8 mouse_utf8_extended}} - } - 1006 { - {origin "xterm" description "Enable SGR Mouse Mode" names {mouse_sgr mouse_sgr_extended} note{ -SET_SGR_EXT_MODE_MOUSE - extended compared to x10 mouse protocol which limits x y coords -to 223 (=255 - 32) - } - } - } - 1015 { - {origin "urxvt" description "Enable urxvt Mouse Mode" names {mouse_urxvt}} - } - 1016 { - {origin "xterm" description "Enable SGR Pixel Mouse Mode" names {mouse_sgr_pixel}} - } - 1047 { - {origin "xterm" description "Alternate Buffer" names {alt_buffer_only}} - } - 1049 { - {origin "xterm" description "Alternate Buffer with save cursor" names {alt_buffer alt_screen}} - } - 2004 { - {origin "xterm" description "Set bracketed paste mode" names {bracketed_paste}} - } - 2027 { - {origin Contour description "Grapheme Cluster Processing" names {grapheme_clusters}} - } - } - set decmode_names [dict create] - dict for {code items} $decmode_data { - foreach itm $items { - set names [dict get $itm names] - foreach nm $names { - dict set decmode_names $nm $code - } - } - } - - - - - - proc query_mode {num_or_name} { - if {[string is integer -strict $num_or_name]} { - set m $num_or_name - } else { - variable decmode_names - if {[dict exists $decmode_names $num_or_name]} { - set m [dict get $decmode_names $num_or_name] - } else { - error "punk::ansi::query_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $decmode_names]" - } - } - return "\x1b\[?$m\$p" - } - - - #Alt screen buffer - smcup/rmcup ti/te - #Note \x1b\[?47h doesn't work at all in some terminals (e.g alacritty,cmd on windows and reportedly kitty) - #It is also reported to have 'deceptively similar' effects to 1049 -but to be 'subtly broken' on some terminals. - #see: https://xn--rpa.cc/irl/term.html - #1049 (introduced by xterm in 1998?) considered the more modern version? - #1047,1048,1049 xterm private modes are 'composite' control sequences as replacement for original 47 sequence - #1049 - includes save cursor,switch to alt screen, clear screen - #e.g ? (below example not known to be exactly what 1049 does - but it's something similar) - #SMCUP - # \x1b7 (save cursor) - # \x1b\[?47h (switch) - # \x1b\[2J (clear screen) - #RMCUP - # \x1b\[?47l (switch back) - # \x1b8 (restore cursor) - - #1047 - clear screen on the way out (ony if actually on alt screen) - proc enable_alt_screen {} { - #tput smcup outputs "\x1b\[?1049h\x1b\[22\;0\;0t" second esc sequence - DECSLPP? setting page height one less than main screen? - return \x1b\[?1049h - } - proc disable_alt_screen {} { - #tput rmcup outputs \x1b\[?1049l\x1b\[23\;0\;0t] - return \x1b\[?1049l - } - #47 - less widely supported(?) doesn't restore cursor or clear alt screen - proc enable_alt_screen2 {} { - return \x1b\[?47h - } - proc disable_alt_screen2 {} { - return \x1b\[?47l - } - - proc term_colour_fg {colour} { - return "\x1b\]10\;$colour\x1b\\" - } - proc term_color_fg {colour} { - return "\x1b\]10\;$colour\x1b\\" - } - proc term_colour_bg {colour} { - return "\x1b\]11\;$colour\x1b\\" - } - proc term_color_bg {colour} { - return "\x1b\]11\;$colour\x1b\\" - } - proc term_colour_cursor {colour} { - return "\x1b\]12\;$colour\x1b\\" - } - proc term_color_cursor {colour} { - return "\x1b\]12\;$colour\x1b\\" - } - proc term_colour_pointer_fg {colour} { - return "\x1b\]13\;$colour\x1b\\" - } - proc term_color_pointer_fg {colour} { - return "\x1b\]13\;$colour\x1b\\" - } - proc term_colour_pointer_bg {colour} { - return "\x1b\]14\;$colour\x1b\\" - } - proc term_color_pointer_bg {colour} { - return "\x1b\]14\;$colour\x1b\\" - } - #15,16 tektronix fg, tektronix bg ??? - proc term_colour_highlight_bg {colour} { - return "\x1b\]17\;$colour\x1b\\" - } - proc term_color_highlight_bg {colour} { - return "\x1b\]17\;$colour\x1b\\" - } - #18 tektronix cursor colour ??? - proc term_colour_highlight_fg {colour} { - return "\x1b\]19\;$colour\x1b\\" - } - proc term_color_highlight_fg {colour} { - return "\x1b\]19\;$colour\x1b\\" - } - #22 pointer shape - there are other methods too - not known to work on windows terminal based VTs - review - proc term_colour_reset {} { - return "\x1b\]104\;\x1b\\" - } - proc term_color_reset {} { - return "\x1b\]104\;\x1b\\" - } - # -- --- --- - - proc erase_line {} { - #*** !doctools - #[call [fun erase_line]] - return \033\[2K - } - proc erase_sol {} { - #*** !doctools - #[call [fun erase_sol]] - #[para]Erase to start of line, leaving cursor position alone. - return \033\[1K - } - proc vt52erase_sol {} { - return \x1bo - } - proc erase_eol {} { - #*** !doctools - #[call [fun erase_eol]] - return \033\[K - } - proc vt52erase_eol {} { - return \x1bK - } - #see also clear_above clear_below - # -- --- --- --- --- - - proc scroll_up {n} { - #*** !doctools - #[call [fun scroll_up] [arg n]] - return \x1b\[${n}S - } - proc scroll_down {n} { - #*** !doctools - #[call [fun scroll_down] [arg n]] - return \x1b\[${n}T - } - - proc insert_spaces {count} { - #*** !doctools - #[call [fun insert_spaces] [arg count]] - return \x1b\[${count}@ - } - proc delete_characters {count} { - #*** !doctools - #[call [fun delete_characters] [arg count]] - return \x1b\[${count}P - } - proc erase_characters {count} { - #*** !doctools - #[call [fun erase_characters] [arg count]] - return \x1b\[${count}X - } - proc insert_lines {count} { - #*** !doctools - #[call [fun insert_lines] [arg count]] - return \x1b\[${count}L - } - proc delete_lines {count} { - #*** !doctools - #[call [fun delete_lines] [arg count]] - return \x1b\[${count}M - } - - proc cursor_pos {} { - #*** !doctools - #[call [fun cursor_pos]] - #[para]cursor_pos unlikely to be useful on it's own like this as when written to the terminal, this sequence causes the terminal to emit the row;col sequence to stdin - #[para]The output on screen will look something like ^[lb][lb]47;3R - #[para]Use punk::console::get_cursor_pos or punk::console::get_cursor_pos_list instead. - #[para]These functions will emit the code - but read it in from stdin so that it doesn't display, and then return the row and column as a colon-delimited string or list respectively. - #[para]The punk::ansi::cursor_pos function is used by punk::console::get_cursor_pos and punk::console::get_cursor_pos_list - return \033\[6n - } - - proc cursor_pos_extended {} { - #includes page e.g ^[[47;3;1R - #(but not on all terminals - some (freebsd?) will report as per 6n e.g ^[[74;3R) - return \033\[?6n - } - - - #DECFRA - Fill rectangular area - #REVIEW - vt100 accepts decimal values 132-126 and 160-255 ("in the current GL or GR in-use table") - #some modern terminals accept and display characters outside this range - but this needs investigation. - #in a modern unicode era - the restricted range doesn't make a lot of sense - but we need to see what terminal emulators actually do. - #e.g what happens with double-width? - #this wrapper accepts a char rather than a decimal value - proc fill_rect {char t l b r} { - set dec [scan $char %c] - return \x1b\[$dec\;$t\;$l\;$b\;$r\$x - } - #DECFRA with decimal char value - proc fill_rect_dec {decimal t l b r} { - return \x1b\[$decimal\;$t\;$l\;$b\;$r\$x - } - - proc checksum_rect {id page t l b r} { - return "\x1b\[${id}\;${page}\;$t\;$l\;$b\;$r*y" - } - - proc request_cursor_information {} { - #*** !doctools - #[call [fun request_cursor_information]] - #[para]DECRQPSR (DEC Request Presentation State Report) for DECCCIR Cursor Information report - #[para]When written to the terminal, this sequence causes the terminal to emit cursor information to stdin - #[para]A stdin readloop will need to be in place to read this information - return \x1b\[1\$w - } - proc request_tabstops {} { - #*** !doctools - #[call [fun request_tabstops]] - #[para]DECRQPSR (DEC Request Presentation State Report) for DECTABSR Tab stop report - #[para]When written to the terminal, this sequence causes the terminal to emit tabstop information to stdin - return \x1b\[2\$w - } - proc set_tabstop {} { - return \x1bH - } - proc clear_tabstop {} { - return \x1b\[g - } - proc clear_all_tabstops {} { - return \x1b\[3g - } - - - #alternative to string terminator is \007 - - proc titleset {windowtitle} { - #*** !doctools - #[call [fun titleset] [arg windowtitles]] - #[para]Returns the code to set the title of the terminal window to windowtitle - #[para]This may not work on terminals which have multiple panes/windows - return "\033\]2;$windowtitle\033\\" ;#works for xterm and most derivatives - } - proc vt52titleset {windowtitle} { - return \x1bS$windowtitle\r - } - #titleget - https://invisible-island.net/xterm/xterm.faq.html#how2_title - #no cross-platform ansi-only mechanism ? - - proc test_decaln {} { - #Screen Alignment Test - #Reset margins, move cursor to the top left, and fill the screen with 'E' - #(doesn't work on many terminals - seems to work in FreeBSD 13.2 and wezterm on windows) - return \x1b#8 - } - - #length of text for printing characters only - #- unicode and other non-printing chars and combining sequences should be handled by the ansifreestring_width call at the end. - #certain unicode chars are full-width (single char 2 columns wide) e.g see "Halfwdith and fullwidth forms" and ascii_fuillwidth blocks in punk::char::charset_names - #review - is there an existing library or better method? printing to a terminal and querying cursor position is relatively slow and terminals lie. - #Note this length calculation is only suitable for lines being appended to other strings if the line is pre-processed to account for backspace and carriage returns first - #If the raw line is appended to another string without such processing - the backspaces & carriage returns can affect data prior to the start of the string. - proc printing_length {line} { - #string last faster than string first for long strings anyway - if {[tcl::string::last \n $line] >= 0} { - error "line_print_length must not contain newline characters" - } - #what if line has \v (vertical tab) ie more than one logical screen line? - - #review - detect ansi moves and warn/error? They would invalidate this algorithm - #for a string with ansi moves - we would need to use the overtype::renderline function (which is a bit heavier) - #arguably - \b and \r are cursor move operations too - so processing them here is not very symmetrical - review - #the purpose of backspace (or line cr) in embedded text is unclear. Should it allow some sort of character combining/overstrike as it has sometimes done historically (nroff/less)? e.g a\b` as an alternative combiner or bolding if same char - #This should presumably only be done if the over_strike (os) capability is enabled in the terminal. Either way - it presumably won't affect printing width? - set line [punk::ansi::ansistrip $line] - #ANSI (e.g PM/SOS) can contain \b or \n or \t but won't contribute to length - #ansistrip must come before any other processing of these chars. - - #we can't use simple \b processing if we get ansi codes and aren't actually processing them (e.g moves) - - set line [punk::char::strip_nonprinting_ascii $line] ;#only strip nonprinting after ansistrip - some like BEL are part of ansi - #backspace 0x08 only erases* printing characters anyway - so presumably order of processing doesn't matter - #(* more correctly - moves cursor back) - #Note some terminals process backspace before \v - which seems quite wrong - #backspace will not move beyond a preceding newline - but we have disallowed newlines for this function already - #leading backspaces will eat into any string (even prompt in non-standard tclsh shell) that is prepended to the line - # - but for the purposes of overtype we wouldn't want that - so we strip it here in the length calculation and should strip leading backspaces in the actual data concatenation operations too. - #curiously - a backspace sequence at the end of a string also doesn't reduce the printing width - so we can also strip from RHS - - #Note that backspace following a \t will only shorten the string by one (ie it doesn't move back the whole tab width like it does interactively in the terminal) - #for this reason - it would seem best to normalize the tabs to spaces prior to performing the backspace calculation - otherwise we won't account for the 'short' tabs it effectivley produces - #normalize tabs to an appropriate* width - #*todo - handle terminal/context where tabwidth != the default 8 spaces - if {[tcl::string::last \t $line] >= 0} { - if {[tcl::info::exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set line [textutil::tabify::untabify2 $line $tw] - } - - #NOTE - this is non-destructive backspace as it occurs in text blocks - and is likely different to the sequence coming from a terminal or editor which generally does a destructive backspace - #e.g - #This means for example that abc\b has a length of 3. Trailing or leading backslashes have no effect - - #set bs [format %c 0x08] - #set line [tcl::string::map [list "\r\b" "\r"] $line] ;#backsp following a \r will have no effect - set line [tcl::string::trim $line \b] ;#take off at start and tail only - - #counterintuitively "x\b" still shows the x ie length is still one. The backspace just moves the position. There must be a char following \b for it to affect the length. - #(we are not interested in the destructive backspace case present in editors,terminals etc - that is a different context) - set n 0 - - #set chars [split $line ""] ; #review - graphemes vs chars? Terminals differ in how they treat this. - set chars [punk::char::grapheme_split $line] - set cr_posns [lsearch -all $chars \r] - set bs_posns [lsearch -all $chars \b] - foreach p $cr_posns { - lset chars $p - } - foreach p $bs_posns { - lset chars $p - } - - #mintty seems more 'correct'. It will backspace over an entire grapheme (char+combiners) whereas windows terminal/wezterm etc remove a combiner - #build an output - set idx 0 - set outchars [list] - set outsizes [list] - # -- - #tcl8.6/8.7 we can get a fast byte-compiled switch statement only with literals in the source code - #this is difficult/risky to maintain - hence the lsearch and grapheme-replacement above - #we could reasonably do it with backspace - but cr is more difficult - #note that \x08 \b etc won't work to create a compiled switch statement even with unbraced (separate argument) form of switch statement. - #set bs "" - #set cr ? - # -- - foreach c $chars { - switch -- $c { - { - if {$idx > 0} { - incr idx -1 - } - } - { - set idx 0 - } - default { - #set nxt [llength $outchars] - if {$idx < [llength $outchars]} { - #overstrike? - should usually have no impact on width - width taken as last grapheme in that column - #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done - #Conceivably double_wide_char then backspace then underscore would underreport the length if overstriking were intended. - lset outchars $idx $c - } else { - lappend outchars $c - } - #punk::ansi::internal::printing_length_addchar $idx $c - incr idx - } - } - } - return [punk::char::ansifreestring_width [join $outchars ""]] - } - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - #with thanks to Helmut Giese and other Authors of tcllib textutil - #this version is adjusted to handle ANSI SGR strings - #TODO! ANSI aware version - - proc untabifyLine { line num } { - variable Spaces - - set currPos 0 - while { 1 } { - set currPos [tcl::string::first \t $line $currPos] - if { $currPos == -1 } { - # no more tabs - break - } - - # how far is the next tab position ? - set dist [expr {$num - ($currPos % $num)}] - # replace '\t' at $currPos with $dist spaces - set line [tcl::string::replace $line $currPos $currPos $Spaces($dist)] - - # set up for next round (not absolutely necessary but maybe a trifle - # more efficient) - incr currPos $dist - } - return $line - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - } - - #ever so slightly slower on short strings - much faster than split_at_codes version for large/complex ansi blocks - lappend PUNKARGS [list { - @id -id ::punk::ansi::ansistrip - @cmd -name punk::ansi::ansistrip\ - -summary\ - "Strip ANSI codes and convert VT100 graphics to unicode equivalents."\ - -help\ - "Returns a string with ANSI codes such as SGR, movements etc stripped out. - Alternate graphics chars (VT100 graphics) are replaced with modern unicode - equivalents (e.g boxdrawing glyphs). - PM, APC, SOS contents are stripped - whether or not such wrapped strings - are displayed on various terminals." - @values -min 1 -max 1 - text -type string - }] - proc ansistrip {text} { - #*** !doctools - #[call [fun ansistrip] [arg text] ] - #[para]Return a string with ansi codes stripped out - #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) - if {[string length $text] < 2} {return $text} - if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters - } - if {[string length $text] < 2} {return $text} - set parts [punk::ansi::ta::split_codes $text] - #review - if we have only one element of a paired codeset such as PM,SOS - it will not be found by split_codes - #The output technically then still contains ansi (which may for example be hidden by terminal despite lack of closing ST) - if {[llength $parts] == 1} {return [lindex $parts 0]} - set out "" - #todo - try: join [lsearch -stride 2 -index 0 -subindices -all -inline $parts *] "" - # - (if/when lsearch -stride bug fixed) - foreach {pt code} $parts { - append out $pt - } - return $out - } - proc ansistrip2 {text} { - #*** !doctools - #[call [fun ansistrip2] [arg text] ] - #[para]Return a string with ansi codes stripped out - #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) - - if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters - } - set parts [punk::ansi::ta::split_codes $text] - #todo - try: join [lsearch -stride 2 -index 0 -subindices -all -inline $parts *] "" - # - (if/when lsearch -stride bug fixed) - join [lmap v [lseq 0 to [llength $parts] by 2] {lindex $parts $v}] "" ;#slightly slower than above foreach - } - #interp alias {} stripansi {} ::punk::ansi::ansistrip - proc ansistripraw {text} { - #*** !doctools - #[call [fun ansistripraw] [arg text] ] - #[para]Return a string with ansi codes stripped out - #[para]Alternate graphics modes will be stripped rather than converted to unicode - exposing the raw ascii characters as they appear without graphics mode. - #[para]ie instead of a horizontal line you may see: qqqqqq - if {[string length $text] < 2} {return $text} - - set parts [punk::ansi::ta::split_codes $text] - set out "" - foreach {pt code} $parts { - append out $pt - } - return $out - } - #interp alias {} stripansiraw {} ::punk::ansi::ansistripraw - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::ansi ---}] -} - -tcl::namespace::eval punk::ansi { - - - # -- --- --- --- --- --- - #XTGETTCAP - # xterm responds with - # DCS 1 + r Pt ST for valid requests, adding to Pt an = , and - # the value of the corresponding string that xterm would send, - # or - # DCS 0 + r ST for invalid requests. - # The strings are encoded in hexadecimal (2 digits per - # character). If more than one name is given, xterm replies - # with each name/value pair in the same response. An invalid - # name (one not found in xterm's tables) ends processing of the - # list of names. - proc xtgetcap {keylist} { - #ESC P = 0x90 = DCS = Device Control String - set hexkeys [list] - foreach k $keylist { - lappend hexkeys [util::str2hex $k] - } - set payload [join $hexkeys ";"] - return "\x1bP+q$payload\x1b\\" - } - proc xtgetcap2 {keylist} { - #ESC P = 0x90 = DCS = Device Control String - set hexkeys [list] - foreach k $keylist { - lappend hexkeys [util::str2hex $k] - } - set payload [join $hexkeys ";"] - return "\u0090+q$payload\u009c" - } - tcl::namespace::eval codetype { - #*** !doctools - #[subsection {Namespace punk::ansi::codetype}] - #[para] API functions for punk::ansi::codetype - #[para] Utility functions for processing ansi code sequences - #[list_begin definitions] - - #Functions that are primarily intended to operate on a single ansi code sequence - rather than a sequence, or codes embedded in another string - #in some cases multiple sequences or leading trailing strings are ok - but the proc docs should note where the function is looking - #review - separate namespace for functions that operate on multiple or embedded? - - proc is_sgr {code} { - #SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline - #we will accept and pass through the less common colon separator (ITU Open Document Architecture) - #Terminals should generally ignore it if they don't use it - regexp {\033\[[0-9;:]*m$} $code - } - - #review - has_cursor_move_in_line? Are we wanting to allow strings/sequences and detect that there are no moves that *aren't* within line? - proc is_cursor_move_in_line {code {knownline ""}} { - if {[regexp {\033\[[0-9]*(:?C|D|G)$} $code]} { - return 1 - } - if {[tcl::string::is integer -strict $knownline]} { - #CSI n : m H where row n happens to be current line - review/test - set re [tcl::string::map [list %n% $knownline] {\x1b\[%n%:[0-9]*H$}] - if {[regexp $re $code]} { - return 1 - } - } - return 0 - } - #pure SGR reset with no other functions - proc is_sgr_reset {code} { - #*** !doctools - #[call [fun is_sgr_reset] [arg code]] - #[para]Return a boolean indicating whether this string has a trailing pure SGR reset - #[para]Note that if the reset is not the very last item in the string - it will not be detected. - #[para]This is primarily intended for testing a single ansi code sequence, but code can be any string where the trailing SGR code is to be tested. - - #todo 8-bit csi - regexp {\x1b\[0*m$} $code - } - - - #whether this code has 0 (or equivalently empty) parameter (but may set others) - #if an SGR code has a reset in it - we don't need to carry forward any previous SGR codes - #it generally only makes sense for the reset to be the first parameter - otherwise the code has ineffective portions - #However - detecting zero or empty parameter in other positions requires knowing all other codes that may allow zero or empty params. - #We only look at the initial parameter within the trailing SGR code as this is the well-formed normal case. - - #Review - consider normalizing sgr codes to remove other redundancies such as setting fg or bg colour twice in same code - proc has_sgr_leadingreset {code} { - #*** !doctools - #[call [fun has_sgr_leadingreset] [arg code]] - #[para]The reset must be the very first item in code to be detected. Trailing strings/codes ignored. - set params "" - #we need non-greedy - if {[regexp {^\033\[([^m]*)m} $code _match params]} { - #must match trailing m to be the type of reset we're looking for - set plist [split $params ";"] - if {[tcl::string::trim [lindex $plist 0] 0] eq ""} { - #e.g \033\[m \033\[0\;...m \033\[0000...m - return 1 - } else { - return 0 - } - } else { - return 0 - } - } - - #e.g has_any_effective $str bg fg - proc has_any_effective {str args} { - set singlecodes [punk::ansi::ta::get_codes_single $str] - set mergeinfo [punk::ansi::codetype::sgr_merge_singles $singlecodes -info 1] - foreach t $args { - switch -- $t { - sgr - unmergeable - othercodes { - if {[dict get $mergeinfo $t] ne ""} { - return 1 - } - } - intensity - italic - underline - underextended - blink - reverse - hide - strike - font - gothic - doubleunderline - - proportional - frame_or_circle - ideogram_underline - ideogram_doubleunderline - ideogram_clear - overline - underlinecolour - superscript - subscript - - nosupersub - fg - bg { - if {[dict get $mergeinfo codestate $t] ne ""} { - return 1 - } - } - bold { - if {[dict get $mergeinfo codestate intensity] eq "1"} { - return 1 - } - } - dim { - if {[dict get $mergeinfo codestate intensity] eq "2"} { - return 1 - } - } - default { - error "punk::ansi::ta::has_any_effective invalid type '$t' specified" - } - } - } - return 0 - } - proc has_all_effective {str args} { - set singlecodes [punk::ansi::ta::get_codes_single $str] - set mergeinfo [punk::ansi::codetype::sgr_merge_singles $singlecodes -info 1] - foreach t $args { - switch -- $t { - sgr - unmergeable - othercodes { - if {[dict get $mergeinfo $t] eq ""} { - return 0 - } - } - intensity - italic - underline - underextended - blink - reverse - hide - strike - font - gothic - doubleunderline - - proportional - frame_or_circle - ideogram_underline - ideogram_doubleunderline - ideogram_clear - overline - underlinecolour - superscript - subscript - - nosupersub - fg - bg { - if {[dict get $mergeinfo codestate $t] eq ""} { - return 0 - } - } - bold { - if {[dict get $mergeinfo codestate intensity] ne "1"} { - return 0 - } - } - dim { - if {[dict get $mergeinfo codestate intensity] ne "2"} { - return 0 - } - } - default { - error "punk::ansi::ta::has_any_effective invalid type '$t' specified" - } - } - } - return 1 - } - - proc is_gx {code} { - #g0 {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} - #g1 {(?:\x1b\)0)(?:(?!\x1b\)B).)*\x1b\)B} - regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code - } - proc is_gx_open {code} { - #todo g2,g3? - #pin to start and end with ^ and $ ? - #regexp {\x1b\(0|\x1b\)0} $code - regexp {\x1b(?:\(0|\)0)} $code - } - proc is_gx_close {code} { - #regexp {\x1b\(B|\x1b\)B} $code - regexp {\x1b(?:\(B|\)B)} $code - } - #input assumed to be single codes - simple test for 2nd char left bracket and trailing m is done anyway - codes not matching are ignored and passed through - #This is not order-preserving if non-sgr codes are present as they are tacked on to the end even if they initially were before all SGR codes - - variable codestate_empty - set codestate_empty [tcl::dict::create] - tcl::dict::set codestate_empty rst "" ;#0 (or empty) - tcl::dict::set codestate_empty intensity "" ;#1 bold, 2 dim, 22 normal - tcl::dict::set codestate_empty shadowed "" ; - tcl::dict::set codestate_empty italic "" ;#3 on 23 off - tcl::dict::set codestate_empty underline "" ;#4 on 24 off - - #nonstandard/extended 4:0,4:1,4:2,4:3,4:4,4:5 - #4:1 single underline and 4:2 double underline deliberately kept separate to standard SGR versions - #The extended codes are merged separately allowing fallback SGR to be specified for terminals which don't support extended underlines - tcl::dict::set codestate_empty underextended "" ;#4:0 for no extended underline 4:1 etc for underline styles - #tcl::dict::set codestate_empty undersingle "" - #tcl::dict::set codestate_empty underdouble "" - #tcl::dict::set codestate_empty undercurly "" - #tcl::dict::set codestate_empty underdotted "" - #tcl::dict::set codestate_empty underdashed "" - - - tcl::dict::set codestate_empty blink "" ;#5 or 6 for slow/fast, 25 for off - tcl::dict::set codestate_empty reverse "" ;#7 on 27 off - tcl::dict::set codestate_empty hide "" ;#8 on 28 off - tcl::dict::set codestate_empty strike "" ;#9 on 29 off - tcl::dict::set codestate_empty font "" ;#10, 11-19 10 being primary - tcl::dict::set codestate_empty gothic "" ;#20 - tcl::dict::set codestate_empty doubleunderline "" ;#21 (standard SGR double as opposed to underdouble) - tcl::dict::set codestate_empty proportional "" ;#26 - see note below - tcl::dict::set codestate_empty frame_or_circle "" ;#51,52 on - 54 off (54 off) (not generally used - mintty has repurposed for emoji variation selector) - - #ideogram rarely supported - this implementation untested - each attribute kept separate as they presumably can be applied simultaneously - tcl::dict::set codestate_empty ideogram_underline "" - tcl::dict::set codestate_empty ideogram_doubleunderline "" - tcl::dict::set codestate_empty ideogram_overline "" - tcl::dict::set codestate_empty ideogram_doubleoverline "" - tcl::dict::set codestate_empty ideogram_clear "" - - tcl::dict::set codestate_empty overline "" ;#53 on 55 off - probably not supported - pass through. Seem to be ok to merge with other SGR even if not supported. - tcl::dict::set codestate_empty underlinecolour "" ;#58 - same arguments as 256colour and rgb (nonstandard - in Kitty ,VTE,mintty and iTerm2) - - # -- mintty? - tcl::dict::set codestate_empty superscript "" ;#73 - tcl::dict::set codestate_empty subscript "" ;#74 - tcl::dict::set codestate_empty nosupersub "" ;#75 - # -- - - tcl::dict::set codestate_empty fg "" ;#30-37 + 90-97 - tcl::dict::set codestate_empty bg "" ;#40-47 + 100-107 - - variable metastate_empty - tcl::dict::set metastate_empty underline_active "" ;#a meta state for whether underlines are on|off - values 1,0,"" - - #misnomer should have been sgr_merge_args ? :/ - #as a common case optimisation - it will not merge a single element list, even if that code contains redundant elements - proc sgr_merge_list {args} { - if {[llength $args] == 0} { - return "" - } elseif {[llength $args] == 1} { - return [lindex $args 0] - } - sgr_merge $args - } - proc sgr_merge {codelist args} { - set allparts [list] - foreach c $codelist { - #set cparts [punk::ansi::ta::split_codes_single $c] - #lappend allparts {*}[lsearch -all -inline -not $cparts ""] - lappend allparts {*}[punk::ansi::ta::get_codes_single $c] - } - sgr_merge_singles $allparts {*}$args - } - - variable defaultopts_sgr_merge_singles - set defaultopts_sgr_merge_singles [tcl::dict::create\ - -filter_fg 0\ - -filter_bg 0\ - -filter_reset 0\ - -info 0\ - ] - - #codes *must* already have been split so that one esc per element in codelist - #e.g codelist [a+ Yellow Red underline] [a+ blue] [a+ red] is ok - #but codelist "[a+ Yellow Red underline][a+ blue]" [a+ red] is not - #(use punk::ansi::ta::split_codes_single) - proc sgr_merge_singles {codelist args} { - variable codestate_empty - variable metastate_empty - variable defaultopts_sgr_merge_singles - set opts $defaultopts_sgr_merge_singles - foreach {k v} $args { - switch -- $k { - -filter_fg - -filter_bg - -filter_reset - - -info { - tcl::dict::set opts $k $v - } - default { - error "sgr_merge unknown option '$k'. Known options [tcl::dict::keys $opts]" - } - } - } - - set othercodes [list] - set codestate $codestate_empty ;#take copy as we need the empty state for resets - set metastate $metastate_empty - set did_reset 0 - - #we should also handle 8bit CSI here? mixed \x1b\[ and \x9b ? Which should be used in the merged result? - #There are arguments to move to 8bit CSI for keyboard protocols (to solve keypress timing issues?) - but does this extend to SGR codes? - #we will output 7bit merge of the SGRs even if some or all were 8bit CSi - #As at 2024 - 7bit are widely supported 8bit seem to be often ignored by pseudoterminals - #auto-detecting and emitting 8bit only if any are present in our input doesn't seem like a good idea - as sgr_merge_list is only seeing a subset of the data - so any auto-decision at this level will just introduce indeterminism. - #review - consider a higher-level option for always emitting 8bit or always 7bit - #either way - if we get mixed CSI input - it probably makes more sense to merge their parameters than maintain the distinction and pass the mess downstream. - - #We still output any non SGR codes in the list as they came in - preserving their CSI - - foreach c $codelist { - #normalize 8bit to a token of the same length so our string operations on the code are the same and we can maintain a switch statement with literals rather than escapes - #.. but preserve original c - #set cnorm [tcl::string::map [list \x9b {8[} ] $c] - #switch -- [tcl::string::index $cnorm 1][string index $cnorm end] {} - # {[m} - - #todo - detect multiple \x9b or \x1b and raise error - codes not split? - #if we don't - we can silently get 8CSI 7CSI in output! - if {[string last \x1b\[ $c] > 0} { - error "::punk::ansi::codetype::sgr_merge_singles bad entry in codelist [ansistring VIEW $c] (There is a 7CSI not at start)" - } - if {[string last \x9b $c] > 0} { - error "::punk::ansi::codetype::sgr_merge_singles bad entry in codelist [ansistring VIEW $c] (There is an 8CSI not at start)" - } - - set cnorm [tcl::string::map [list \x9b 8CSI "\x1b\[" 7CSI ] $c] - switch -- [tcl::string::range $cnorm 0 3][tcl::string::index $cnorm end] { - 7CSIm - 8CSIm { - #set params [tcl::string::range $cnorm 2 end-1] ;#strip leading esc lb and trailing m - set params [tcl::string::range $cnorm 4 end-1] ;#string leading XCSI and trailing m - - #some systems use colon for 256 colours or RGB or nonstandard subparameters - #- it is therefore probably not ok to map to semicolon within SGR codes and treat the same. - # - will break mintty? set params [tcl::string::map [list : {;}] $params] - set plist [split $params {;}] - if {![llength $plist]} { - #if there was nothing - it must be a reset - we need it in the list - lappend plist "" - } - #we shouldn't get an empty or zero param beyond index 0 - but it's possible - #some codes have additional parameters - e.g rgb colours so we need to jump forward in the parameter list sometimes. - for {set i 0} {$i < [llength $plist]} {incr i} { - set p [lindex $plist $i] - set paramsplit [split $p :] - #for some cases we passthrough $p instead of just the number - in case another implementation uses the colon subparameters - #e.g see https://github.com/mintty/mintty/wiki/Tips#text-attributes-and-rendering - #this may have originated with kitty? - #windows terminal seems to be implementing it too - #however, they can be completely repurposed - so we probably need to specifically support them.. REVIEW. - - #review - what about \x1b\[000m - #we need to accept/ignore leading zeros - we can't just pass to expr - as some tcl versions still see leading zero as octal - set codeint [tcl::string::trimleft [lindex $paramsplit 0] 0] - switch -- $codeint { - "" - 0 { - if {![tcl::dict::get $opts -filter_reset]} { - set codestate $codestate_empty - set metastate $metastate_empty - set did_reset 1 - } - } - 1 { - #bold - if {[llength $paramsplit] == 1} { - tcl::dict::set codestate intensity $p - } else { - if {[lindex $paramsplit 1] eq "2"} { - tcl::dict::set codestate shadowed "1:2" ;#turn off also with 22 - } - } - } - 2 { - #dim - tcl::dict::set codestate intensity 2 - } - 3 { - tcl::dict::set codestate italic 3 - } - 4 { - #REVIEW - merging extended (e.g 4:4) underline attributes suppresses all other SGR attributes on at least some terminals which don't support extended underlines - #e.g hyper on windows - if {[llength $paramsplit] == 1} { - tcl::dict::set codestate underline 4 - if {[tcl::dict::get $codestate underextended] eq "4:0"} { - tcl::dict::set codestate underextended "" - } - tcl::dict::set metastate underline_active 1 - } else { - switch -- [lindex $paramsplit 1] { - 0 { - #no *extended* underline - #tcl::dict::set codestate underline 24 - tcl::dict::set codestate underextended 4:0 ;#will not turn off SGR standard underline if term doesn't support extended - tcl::dict::set metastate underline_active 0 - } - 1 { - #single - tcl::dict::set codestate underextended 4:1 - tcl::dict::set metastate underline_active 1 - } - 2 { - #double - tcl::dict::set codestate underextended 4:2 - tcl::dict::set metastate underline_active 1 - } - 3 { - #curly - tcl::dict::set codestate underextended "4:3" - tcl::dict::set metastate underline_active 1 - } - 4 { - #dotted - tcl::dict::set codestate underextended "4:4" - tcl::dict::set metastate underline_active 1 - } - 5 { - #dashed - tcl::dict::set codestate underextended "4:5" - tcl::dict::set metastate underline_active 1 - } - } - - } - } - 5 - 6 { - tcl::dict::set codestate blink $p - } - 7 { - tcl::dict::set codestate reverse 7 - } - 8 { - tcl::dict::set codestate hide 8 - } - 9 { - tcl::dict::set codestate strike 9 - } - 10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 { - tcl::dict::set codestate font $p - } - 20 { - tcl::dict::set codestate gothic 20 - } - 21 { - #ECMA-48 double underline - some terminals use as not-bold. For now we won't support that. - tcl::dict::set codestate doubleunderline 21 - } - 22 { - #normal intensity - tcl::dict::set codestate intensity 22 - tcl::dict::set codestate shadowed "" - } - 23 { - #? wikipedia mentions blackletter - review - tcl::dict::set codestate italic 23 - } - 24 { - tcl::dict::set codestate underline 24 ;#off - tcl::dict::set codestate underextended "4:0" ;#review - tcl::dict::set metastate underline_active 0 - } - 25 { - tcl::dict::set codestate blink 25 ;#off - } - 26 { - #not known to be used in terminals.. could it be used with elastic tabstops? - review - tcl::dict::set codestate proportional 26 - } - 27 { - tcl::dict::set codestate reverse 27 ;#off - } - 28 { - tcl::dict::set codestate hide 28 ;#reveal - } - 29 { - tcl::dict::set codestate strike 29;#off - } - 30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 { - tcl::dict::set codestate fg $p ;#foreground colour - } - 38 { - #256 colour or rgb - #check if subparams supplied as colon separated - if {[tcl::string::first : $p] < 0} { - switch -- [lindex $plist $i+1] { - 5 { - #256 - 1 more param - tcl::dict::set codestate fg "38\;5\;[lindex $plist $i+2]" - incr i 2 - } - 2 { - #rgb - tcl::dict::set codestate fg "38\;2\;[lindex $plist $i+2]\;[lindex $plist $i+3]\;[lindex $plist $i+4]" - incr i 4 - } - } - } else { - #apparently subparameters can be left empty - and there are other subparams like transparency and colour-space - #we should only need to pass it all through for the terminal to understand - #review - tcl::dict::set codestate fg $p - } - } - 39 { - tcl::dict::set codestate fg 39 ;#default foreground - } - 40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 { - tcl::dict::set codestate bg $p ;#background colour - } - 48 { - #256 colour or rgb - if {[tcl::string::first : $p] < 0} { - switch -- [lindex $plist $i+1] { - 5 { - #256 - 1 more param - tcl::dict::set codestate bg "48\;5\;[lindex $plist $i+2]" - incr i 2 - } - 2 { - #rgb - tcl::dict::set codestate bg "48\;2\;[lindex $plist $i+2]\;[lindex $plist $i+3]\;[lindex $plist $i+4]" - incr i 4 - } - } - } else { - tcl::dict::set codestate bg $p - } - } - 49 { - tcl::dict::set codestate bg 49 ;#default background - } - 50 { - tcl::dict::set codestate proportional 50 ;#off - see 26 - } - 51 - 52 { - tcl::dict::set codestate frame_or_circle 51 - } - 53 { - tcl::dict::set codestate overline 53 ;#not supported in terminals? pass through anyway - } - 54 { - tcl::dict::set codestate frame_or_circle 54 ;#off - } - 55 { - tcl::dict::set codestate overline 55; #off - } - 58 { - #nonstandard - # 256 colour or rgb - if {[tcl::string::first : $p] < 0} { - switch -- [lindex $plist $i+1] { - 5 { - # 256 - 1 more param - tcl::dict::set codestate underlinecolour "58\;5\;[lindex $plist $i+2]" - incr i 2 - } - 2 { - #rgb - tcl::dict::set codestate underlinecolour "58\;2\;[lindex $plist $i+2]\;[lindex $plist $i+3]\;[lindex $plist $i+4]" - incr i 4 - } - } - } else { - tcl::dict::set codestate underlinecolour $p - } - } - 59 { - #nonstandard - default underlinecolour - tcl::dict::set codestate underlinecolour 59 - } - 60 { - tcl::dict::set codestate ideogram_underline 60 - tcl::dict::set codestate ideogram_clear "" - #nounderline effect? review! - } - 61 { - tcl::dict::set codestate ideogram_doubleunderline 61 - tcl::dict::set codestate ideogram_clear "" - #nounderline effect? review! - } - 62 { - tcl::dict::set codestate ideogram_overline 62 - tcl::dict::set codestate ideogram_clear "" - } - 63 { - tcl::dict::set codestate ideogram_doubleoverline 63 - tcl::dict::set codestate ideogram_clear "" - } - 64 { - tcl::dict::set codestate ideogram_stress 64 - tcl::dict::set codestate ideogram_clear "" - } - 65 { - tcl::dict::set codestate ideogram_clear 65 - #review - we still need to pass through the ideogram_clear in case something understands it - tcl::dict::set codestate ideogram_underline "" - tcl::dict::set codestate ideogram_doubleunderline "" - - tcl::dict::set codestate ideogram_overline "" - tcl::dict::set codestate ideogram_doubleoverline "" - } - 73 { - #mintty only? - #can be combined with subscript - tcl::dict::set codestate superscript 73 - tcl::dict::set codestate nosupersub "" - } - 74 { - tcl::dict::set codestate subscript 74 - tcl::dict::set codestate nosupersub "" - } - 75 { - tcl::dict::set codestate nosupersub 75 - tcl::dict::set codestate superscript "" - tcl::dict::set codestate subcript "" - } - 90 - 91 - 92 - 93 - 94 - 95 - 96 - 97 { - tcl::dict::set codestate fg $p - } - 100 - 101 - 102 - 103 - 104 - 105 - 106 - 107 { - tcl::dict::set codestate bg $p - } - - } - } - } - default { - lappend othercodes $c - } - } - - } - - set codemerge "" - set unmergeable "" ;# can merge with each other but not main set (for terminals not supporting extended codes) - if {[tcl::dict::get $opts -filter_fg] || [tcl::dict::get $opts -filter_bg]} { - #safe jumptable test - #dict for {k v} $codestate {} - tcl::dict::for {k v} $codestate { - switch -- $v { - "" { - } - default { - switch -- $k { - bg { - if {![tcl::dict::get $opts -filter_bg]} { - append codemerge "${v}\;" - } - } - fg { - if {![tcl::dict::get $opts -filter_fg]} { - append codemerge "${v}\;" - } - } - underlinecolour - underextended { - #review - append unmergeable "${v}\;" - } - default { - append codemerge "${v}\;" - } - } - } - } - } - } else { - #safe jumptable test - #dict for {k v} $codestate {} - tcl::dict::for {k v} $codestate { - switch -- $v { - "" {} - default { - switch -- $k { - underlinecolour { - append unmergeable "${v}\;" - } - underextended { - #review - append unmergeable "${v}\;" - } - default { - append codemerge "${v}\;" - } - } - } - } - } - } - if {$did_reset} { - #review - unmergeable - set codemerge "0\;$codemerge" - if {$codemerge eq ""} { - set unmergeable "0\;$unmergeable" - } - } - #puts "+==> codelist:[ansistring VIEW $codelist] did_reset:$did_reset codemerge:[ansistring VIEW $codemerge] unmergeable:[ansistring VIEW $unmergeable]" - if {$codemerge ne ""} { - set codemerge [tcl::string::trimright $codemerge {;}] - if {$unmergeable ne ""} { - set unmergeable [tcl::string::trimright $unmergeable {;}] - set mergeresult "\x1b\[${codemerge}m\x1b\[${unmergeable}m[join $othercodes ""]" - } else { - set mergeresult "\x1b\[${codemerge}m[join $othercodes ""]" - } - } else { - if {$unmergeable eq ""} { - #there were no SGR codes - not even resets - set mergeresult [join $othercodes ""] - } else { - set unmergeable [tcl::string::trimright $unmergeable {;}] - set mergeresult "\x1b\[${unmergeable}m[join $othercodes ""]" - } - } - if {[tcl::dict::get $opts -info]} { - return [dict create sgr $codemerge unmergeable $unmergeable othercodes $othercodes mergeresult $mergeresult codestate $codestate] - } else { - return $mergeresult - } - } - - #has_sgr_reset - rather than support this function - create an sgr normalize function that removes dead params and brings reset to front of param list? - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::ansi::codetype ---}] - } - tcl::namespace::eval sequence_type { - #first byte after ESC identifies code type - #NOTE - we are looking for valid start of a single sequence here - #- not whether it is complete or where it ends, unless it's a fixed number of bytes - - #\u0020-\u002F - # ESC !"#$%&'()*+,-./ - - #\u0030-\u003F - #ESC 0-9:;<=>? - - #\u0040-\u005F - # ESC @A-Z[\]^ - - #\u0060-\u007E - - proc is_Fe7 {code} { - # C1 control codes - #7bit - typical case - # ESC @A-Z[\]^ - return [regexp {^\033[\u0040-\u005F]} $code] - } - proc is_Fe {code} { - #although Fe7 more common - we'll put the simpler regex for 8 first - return [expr {[is_Fe8 $code] || [is_Fe7 $code]}] - } - proc is_Fe8 {code} { - #8bit - #review - all C1 escapes ? 0x80-0x9F - #This is possibly problematic as it is affected by encoding. - #According to https://en.wikipedia.org/wiki/ANSI_escape_code#8-bit - #"However, in character encodings used on modern devices such as UTF-8 or CP-1252, those codes are often used for other purposes, so only the 2-byte sequence is typically used." - return [regexp {^[\u0080-\u09F]} $code] - } - #ESC 0-9,:,;,<,=,>,? - proc is_Fp {code} { - #single byte following ESC - return [regexp {^\033[\u0030-\u003F]$} $code] - } - - #https://en.wikipedia.org/wiki/ISO/IEC_2022 - #e.g - # ESC a (INT) interrupts the current process - # ESC c (RIS) reset terminal to initial state - #ESC `a-z{|}~ - proc is_Fs {code} { - #single byte following ESC - return [regexp {^\033[\u0060-\u007E]$} $code] - } - - - proc is_nF {code} { - #2 bytes - #subcategorised by the low two bits of the first byte (n) - #further by whether the final byte is in \u0030-u003f (p) or not (t) - return [regexp {^\033[\u0020-\u002F]+[\u0030-\u007E]$} $code] - } - - #review - test - #3Fp - private use - #e.g vt100 - # ESC#3 DECDHL double-height letters top half - # ESC#4 DECDHL double-height letters bottom half - # ESC#5 DECSWL single-width line - # ESC#6 DECDWL double-width line - proc is_3Fp {code} { - return [regexp {^\033#[\u0020-\u002F]*[\u0030-\u003F]$} $code] ;#check regexp - } - - proc is_code7 {code} { - #Fe | Fs | Fp | nF | Fe - return [regexp {^\033[\u0040-\u005F]|^\033[\u0060-\u007e]$|^\033[\u0030-\u003F]$|^\033[\u0020-\u002F]+[\u0030-\u007E]$} $code] - } - proc is_code8 {code} { - return [regexp {^[\u0080-\u09F]} $code] - } - proc is_code {code} { - return [expr {[is_code8 $code] || [is_code7 $code]}] - } - - proc classify {code} { - return [switch -regexp -- $code { - {^\033[\u0030-\u003F]$} {string cat Fp} - {^[\u0080-\u009F]|^\033[\u0040-\u005F]} {string cat Fe} - {^\033[\u0060-\u007E]$} {string cat Fs} - {^\033[\u0020-\u002F]+[\u0030-\u007E]$} { - #nF sequences - set firstbytenum [scan [string index $code 1] %c] - set lastbyte [string index $code end] - - set n [expr {$firstbytenum & 3}] - if {[regexp {[\u0030-\u003F]} $lastbyte]} { - set tp p - } else { - set tp t - } - string cat ${n}F$tp - } - {^\033#[\u0020-\u002F]*[\u0030-\u003F]$} {string cat 3Fp} - default {string cat unknown} - }] - } - } - # -- --- --- --- --- --- --- --- --- --- --- - #todo - implement colour resets like the perl module: - #https://metacpan.org/pod/Text::ANSI::Util - #(saves up all ansi colour codes since previous colour reset and replays the saved codes after our highlighting is done) -} - - -tcl::namespace::eval punk::ansi::ta { - #*** !doctools - #[subsection {Namespace punk::ansi::ta}] - #[para] text ansi functions - #[para] based on but not identical to the Perl Text Ansi module: - #[para] https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm - #[list_begin definitions] - tcl::namespace::path ::punk::ansi - namespace export detect detect_in_list detect_sgr extract length split_codes split_at_codes split_codes_single - - variable PUNKARGS - - #handle both 7-bit and 8-bit csi - #review - does codepage affect this? e.g ebcdic has 8bit csi in different position - - #CSI - #variable re_csi_open {(?:\033\[|\u009b)[0-9;]+} ;#too specific - doesn't detect \033\[m - variable re_csi_open {(?:\x1b\[|\u009b)} - #variable re_csi_code {(?:\033\[|\u009b)[0-9;]*[a-zA-Z\\@\^_\{|\}\[\]~`]} - variable re_csi_code {(?:\x1b\[|\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]} - - #intermediate bytes range 0x20-0x2F (ascii space and !"#$%&'()*+,-./) - #parameter bytes range 0x30-0x3F (ascii 0-9:;<=>?) - #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). - - #colour and style - variable re_sgr {(?:\033\[|\u009b)[0-9;]*m} ;#e.g \033\[31m \033\[m \033\[0m \033\[m0000m - - #OSC - termnate with BEL (\a \007) or ST (string terminator \x1b\\) - # 8-byte string terminator is \x9c (\u009c) - - #non-greedy by excluding ST terminators - variable re_esc_osc1 {(?:\x1b\])(?:[^\007]*)\007} - #variable re_esc_osc2 {(?:\033\])(?:[^\033]*)\033\\} ;#somewhat wrong - we want to exclude the ST - not other esc sequences - variable re_esc_osc2 {(?:\x1b\])(?:(?!\x1b\\).)*\x1b\\} - variable re_esc_osc3 {(?:\u009d)(?:[^\u009c]*)?\u009c} - variable re_osc_open {(?:\x1b\]|\u009d).*} - - - #review - distinguishing standalone codes vs those that are paired with contents considered part of the code - #e.g PM,SOS are 'paired' ended by ST - - #variable standalone_code_map [list \x1bc "" \x1b7 "" \x1b8 "" \x1bM "" \x1bE "" \x1bD "" \x1bH "" \x1b= "" \x1b> "" \x1b#3 "" \x1b#4 "" \x1b#5 "" \x1b#6 "" \x1b#8 ""] - variable re_standalones {(?:\x1bc|\x1b7|\x1b8|\x1bM|\x1bD|\x1bE|\x1bH|\x1b=|\x1b>|\x1b#3|\x1b#4|\x1b#5|\x1b#6|\x1b#8)} - variable re_standalones_vt52 {(?:\x1bZ)} - - # -- - #ESC Y move - \x1bY ie 2 bytes to close - #ESC b foreground colour - \x1bb 1 byte to close - variable re_vt52_incomplete {(?:\x1bY(.){0,1}$|\x1bb$)} - #\x1bc vt52 bgcolour conflict ? - #ESC F - gr-on ESC G - gr-off - # -- - - #if we don't split on altgraphics too and separate them out - it's easy to get into a horrible mess - variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} - variable re_g0_open {(?:\x1b\(0)} - variable re_g0_close {(?:\x1b\(B)} - - #detect start of ansicode that is closed by ST - # DCS "ESC P" or "0x90" is also terminated by ST - set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} - #ST terminators [list \007 \033\\ \u009c] - - #regex to capture the start of string/privacy message/application command block including the contents and string terminator (ST) - #non-greedy by exclusion of ST terminators in body - #we need to match \x1b\\ not just \x1b There could be colour codes nested in a privacy msg/string (not widely supported?) - #even if terminals generally don't support that - it's quite possible for an ansi code to get nested this way - and we'd prefer it not to break our splits - #Just checking for \x1b will terminate the match too early - #we also need to track the start of ST terminated code and not add it for replay (in the ansistring functions) - #variable re_ST {(?:\x1bX|\u0098|\x1b\^|\u009E|\x1b_|\u009F)(?:[^\x1b\007\u009c]*)(?:\x1b\\|\007|\u009c)} ;#downsides: early terminating with nests, mixes 7bit 8bit start/ends (does that exist in the wild?) - #keep our 8bit/7bit start-end codes separate - variable re_ST {(?:\x1bP|\x1bX|\x1b\^|\x1b_)(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007)|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)} - - - #variable re_ansi_detect_open "${re_csi_open}|${re_osc_open}|${re_standalones}|${re_standalones_vt52}|${re_ST_open}|${re_g0_open}|${re_vt52_open}" - #variable re_ansi_detect_open "${re_csi_open}|${re_osc_open}|${re_ST_open}|${re_g0_open}|${re_vt52_open}" - variable re_ansi_detect_open "${re_csi_open}|${re_osc_open}|${re_ST_open}|${re_vt52_incomplete}" - - #consider standalones as self-opening/self-closing - therefore included in both ansi_detect and ansi_detect_open - - #default for regexes is non-newline-sensitive matching - ie matches can span lines - # -- --- --- --- - #variable re_ansi_detect1 "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_g0_open}|${re_g0_close}" - # -- --- --- --- - #handrafted TRIE version of above. Somewhat difficult to construct and maintain. TODO - find a regexp TRIE generator that works with Tcl regexes - #This does make things quicker - but it's too early to finalise the detect/split regexes (e.g missing \U0090 ) - will need to be redone. - #variable re_ansi_detect {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} - - #NOTE - the literal # char can cause problems in expanded syntax - even though it's within a bracketed section. \# seems to work though. - #vt52 specific |<|A|B|C|I|J|K|L|M|Z|(?:Y(?:..))|(?:b(?:.)| - #https://freemint.github.io/tos.hyp/en/VT_52_terminal.html - #what to with ESC c vs vt52 ESC c (background colour) ??? - #we probably need to use a separate re_ansi_detect for vt52 - - #although it's stated later terminals are backwards compatible with vt52 - that doesn't seem to mean for example a vt100 will process vt52 codes at the same time as ansi codes - #ie - when DECANM is on - VT52 codes are *not* processed - - #todo - ansi mode and cursor key mode set ? - # arrow keys -> ESC O A, ESC O B, ESC O C, ESC O D - # plus more for auxiliary keypad codes in keypad application mode (and some in numeric mode) - - #regexp expanded syntax = ?x - #full detect - checking for closing sequences - variable re_ansi_detect {(?x) - (?:\x1b(?:\[(?:[\x20-\x3f]*[\x40-\x7e])|a|c|7|8|M|D|E|H|=|>|<|A|B|C|I|J|K|L|M|Z|(?:Y(?:..))|(?:b(?:.))|\((?:0|B)|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|(?:\#(?:3|4|5|6|8)))) - |(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c) - |(?:\u009b)[\x20-\x3f]*[\x40-\x7e] - |(?:\u009d)(?:[^\u009c]*)?\u009c - } - #--- - #todo - #variable re_ansi_detectcode $re_ansi_detect - #variable re_ansi_detectcode {\x1b[\u0040-\u005F]|\x1b[\u0060-\u007e]|\x1b[\u0030-\u003F]|\x1b[\u0020-\u002F]+[\u0030-\u007E]} - variable re_ansi_detectcode {(?:\x1b(?:[\u0030-\u007E]|[\u0020-\u002F]+[\u0030-\u007E]))|[\u0090-\u009F]} - - # -- --- --- --- - #variable re_csi_code {(?:\x1b\[|\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]} - - - - - #may be same as detect - kept in case detect needs to diverge - #variable re_ansi_split "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_g0_open}|${re_g0_close}" - set re_ansi_split $re_ansi_detect - variable re_ansi_split_multi - if {[string first (?x) $re_ansi_split] == 0} { - set re_ansi_split_multi "(?x)(?:[string range ${re_ansi_split} 4 end])+" - } else { - set re_ansi_split_multi "(?:${re_ansi_split})+" - } - - - #*** !doctools - #[call [fun detect] [arg text]] - #[para]Return a boolean indicating whether Ansi codes were detected in text - #[para]Important caveat: - #[para] When text is a tcl list made from splitting (or lappending) some ansi string - individual elements may be braced or have certain chars escaped. (one example is if a list element contains an unbalanced brace) - #[para] This can cause square brackets that form part of the ansi being backslash escaped - and the regexp can fail to match - - #detect any ansi escapes - #review - only detect 'complete' codes - or just use the opening escapes for performance? - lappend PUNKARGS [list { - @id -id ::punk::ansi::ta::detect - @cmd -name punk::ansi::ta::detect\ - -summary\ - "Test if text has completed ANSI codes"\ - -help\ - "Return a boolean indicating whether *complete* Ansi codes were detected in text. - - By complete, it means that paired squences such as PM (privacy message) must be - closed. It also means that a truncated sequence such as \\x1b\\\[ or a lone escape - will not be detected as ANSI. - - Use punk::ansi::ta::detectcode as a slightly faster detector for ANSI codes, that does - not require paired sequences to have both starting and end sequences to be detected. - - Important caveat: - When text is a tcl list made from splitting (or lappending) some ansi string - - individual elements may be braced or have certain chars escaped. - (one example is if a list element contains an unbalanced brace) - This can cause square brackets that form part of the ansi to be backslash escaped - - and the function can fail to match it as an Ansi code. - " - @values -min 1 - text -type string -help\ - "Block of text. See caveat above about lists." - } ] - proc detect {text} [string map [list [list $re_ansi_detect]] { - regexp $text - }] - #can be used on dicts - but will check keys too. keys could also contain ansi and have escapes - proc detect_in_list {list} { - #loop is commonly faster than using join. (certain ansi codes triggering list quoting? review) - foreach item $list { - if {[detect $item]} { - return 1 - } - } - return 0 - } - - #will detect for example lone opening or closing PM - proc detectcode {text} [string map [list [list $re_ansi_detectcode]] { - regexp $text - }] - proc detectcode_in_list {list} { - #loop is commonly faster than using join. (certain ansi codes triggering list quoting? review) - foreach item $list { - if {[detectcode $item]} { - return 1 - } - } - return 0 - } - - - #surprisingly - the ::join operation can be (relatively) slow on lists containing ansi - proc detect_in_list2 {list} { - detect [join $list " "] - } - - proc detect_g0 {text} [string map [list [list $re_g0_group]] { - regexp $text - }] - #note - micro optimisation of inlining gives us *almost* nothing extra. - #left in place for a few such as detect/detect_g0 as we want them as fast as possible - # in general the technique doesn't seem particularly worthwhile for this set of functions. - #the performance is dominated by the complexity of the regexp - proc detect2 {text} { - variable re_ansi_detect - expr {[regexp $re_ansi_detect $text]} - } - - proc detect_open {text} { - variable re_ansi_detect_open - expr {[regexp $re_ansi_detect_open $text]} - } - proc detect_st_open {text} { - variable re_ST_open - expr {[regexp $re_ST_open $text]} - } - - #not in perl ta - proc detect_csi {text} { - #*** !doctools - #[call [fun detect_csi] [arg text]] - #[para]Return a boolean indicating whether an Ansi Control Sequence Introducer (CSI) was detected in text - #[para]The csi is often represented in code as \x1b or \033 followed by a left bracket [lb] - #[para]The initial byte or escape is commonly referenced as ESC in Ansi documentation - #[para]There is also a multi-byte escape sequence \u009b - #[para]This is less commonly used but is also detected here - #[para](This function is not in perl ta) - variable re_csi_open - expr {[regexp $re_csi_open $text]} - } - proc detect_sgr {text} { - #*** !doctools - #[call [fun detect_sgr] [arg text]] - #[para]Return a boolean indicating whether an ansi Select Graphics Rendition code was detected. - #[para]This is the set of CSI sequences ending in 'm' - #[para]This is most commonly an Ansi colour code - but also things such as underline and italics - #[para]An SGR with empty or a single zero argument is a reset of the SGR features - this is also detected. - #[para](This function is not in perl ta) - variable re_sgr - expr {[regexp $re_sgr $text]} - } - - #perl: ta_strip - proc strip {text} { - #*** !doctools - #[call [fun strip] [arg text]] - #[para]Return text stripped of Ansi codes - #[para]This is a tailcall to punk::ansi::ansistrip - tailcall ansistrip $text - } - - lappend PUNKARGS [list { - @id -id ::punk::ansi::ta::extract - @cmd -name punk::ansi::ta::extract\ - -summary\ - "Return only the ANSI codes in text"\ - -help\ - "This is the opposite of strip, - returning only the ANSI codes in text." - @values -min 1 -max 1 - text -type string - } ] - proc extract {text} { - set parts [split_codes $text] - set out "" - foreach {pt code} $parts { - append out $code - } - return $out - } - - lappend PUNKARGS [list { - @id -id ::punk::ansi::ta::length - @cmd -name punk::ansi::ta::length\ - -summary\ - "Calculate length of text (excluding the ANSI codes)"\ - -help\ - "Calculate length of text (excluding the ANSI codes) - This is not the printing length of the string on screen." - @values -min 1 - text -type string - } ] - #perl: ta_length - proc length {text} { - #*** !doctools - #[call [fun length] [arg text]] - #[para]Return the character length after stripping ansi codes - not the printing length - - #we can use ansistripraw to avoid g0 conversion - as the length should remain the same - tcl::string::length [ansistripraw $text] - } - #todo - handle newlines - #not in perl ta - #proc printing_length {text} { - # - #} - - #perl: ta_trunc - #truncate $text to $width columns while still including all the ANSI colour codes. - proc trunc {text width args} { - - } - - #not in perl ta - #returns just the plaintext portions in a list - proc split_at_codes {str} [string map [list $re_ansi_split] { - #variable re_ansi_split - #punk::ansi::internal::splitx $str ${re_ansi_split} - punk::ansi::ta::Do_split_at_codes $str {} - }] - #it is faster to split this function out than to inline it into split_at_codes in tcl 8.7 - something to do with the use of the variable vs argument for the regexp - #literal inlining of the re in the main proc-body was slower too - but inlining it into the wrapper seems to work (a tiny bit) - #the difference is not often apparent when comparing timerate results from split_at_codes vs split_at_codes2 - - # - but in aggregate for something like textblock::periodic - we can get a bit over 5% faster (e.g 136ms vs 149ms) - proc Do_split_at_codes {str regexp} { - if {$str eq ""} { - return {} - } - #no infinite loop check on regexp like splitx does because we should have tested re_ansi_split during development - set list {} - set start 0 - while {[regexp -start $start -indices -- $regexp $str match submatch]} { - lassign $submatch subStart subEnd - lassign $match matchStart matchEnd - incr matchStart -1 - incr matchEnd - lappend list [tcl::string::range $str $start $matchStart] - if {$subStart >= $start} { - lappend list [tcl::string::range $str $subStart $subEnd] - } - set start $matchEnd - } - lappend list [tcl::string::range $str $start end] - return $list - - } - proc Do_split_at_codes_join {str regexp} { - if {$str eq ""} { - return {} - } - #no infinite loop check on regexp like splitx does because we should have tested re_ansi_split during development - set list {} - set start 0 - while {[regexp -start $start -indices -- $regexp $str match submatch]} { - lassign $submatch subStart subEnd - lassign $match matchStart matchEnd - incr matchStart -1 - incr matchEnd - lappend list [tcl::string::range $str $start $matchStart] - if {$subStart >= $start} { - lappend list [tcl::string::range $str $subStart $subEnd] - } - set start $matchEnd - } - lappend list [tcl::string::range $str $start end] - return [join $list ""] - } - proc split_at_codes2 {str} [string map [list $re_ansi_split] { - #variable re_ansi_split - #punk::ansi::internal::splitx $str ${re_ansi_split} - - #set regexp $re_ansi_split - #set regexp {} - - #inline splitx to avoid regex checks - #from textutil::split::splitx - # Bugfix 476988 - if {$str eq ""} { - return {} - } - #if {[regexp $regexp {}]} { - # return -code error \ - # "splitting on regexp \"$re_ansi_split\" would cause infinite loop" - #} - #no infinite loop check on regexp like splitx does because we should have tested re_ansi_split during development - set list {} - set start 0 - while {[regexp -start $start -indices -- {} $str match submatch]} { - lassign $submatch subStart subEnd - lassign $match matchStart matchEnd - incr matchStart -1 - incr matchEnd - lappend list [tcl::string::range $str $start $matchStart] - if {$subStart >= $start} { - lappend list [tcl::string::range $str $subStart $subEnd] - } - set start $matchEnd - } - lappend list [tcl::string::range $str $start end] - return $list - }] - - # -- --- --- --- --- --- - #Split $text to a list containing alternating ANSI colour codes and text. - #ANSI colour codes are always on the second element, fourth, and so on. - #(ie plaintext on even list-indices ansi on odd indices) - #result of split on non-empty string always has an odd length - with indices 0 and end always being plaintext (possibly empty string) - # Example: - #split_codes "" # => "" - #split_codes "a" # => "a" - #split_codes "a\e[31m" # => {"a" "\e[31m" ""} - #split_codes "\e[31ma" # => {"" "\e[31m" "a"} - #split_codes "\e[31ma\e[0m" # => {"" "\e[31m" "a" "\e[0m" ""} - #split_codes "\e[31ma\e[0mb" # => {"" "\e[31m" "a" "\e[0m", "b"} - #split_codes "\e[31m\e[0mb" # => {"" "\e[31m\e[0m" "b"} - # - proc split_codes {text} { - variable re_ansi_split_multi - return [_perlish_split $re_ansi_split_multi $text] - } - #micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds) - - #like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so even/odd indices for plain ansi still holds) - #- the slightly simpler regex than split_codes means that it will be slightly faster than keeping the codes grouped. - proc split_codes_single {text} { - if {$text eq ""} { - return {} - } - variable re_ansi_split - set next 0 - #set b -1 - set list [list] - set coderanges [regexp -indices -all -inline -- $re_ansi_split $text] - foreach cr $coderanges { - lappend list [tcl::string::range $text $next [lindex $cr 0]-1] [tcl::string::range $text [lindex $cr 0] [lindex $cr 1]] - set next [expr {[lindex $cr 1]+1}] - #set next [lindex $cr 1]+1 ;#text index-expression for string range - } - lappend list [tcl::string::range $text $next end] - return $list - } - proc split_codes_single2 {text} { - variable re_ansi_split - return [_perlish_split $re_ansi_split $text] - } - proc get_codes_single {text} { - variable re_ansi_split - regexp -all -inline -- $re_ansi_split $text - } - - #review - tcl greedy expressions may match multiple in one element - proc _perlish_split {re text} { - if {$text eq ""} { - return {} - } - set next 0 - #set b -1 - set list [list] - set coderanges [regexp -indices -all -inline -- $re $text] - foreach cr $coderanges { - lappend list [tcl::string::range $text $next [lindex $cr 0]-1] [tcl::string::range $text [lindex $cr 0] [lindex $cr 1]] - set next [expr {[lindex $cr 1]+1}] - } - lappend list [tcl::string::range $text $next end] - return $list - } - proc _perlish_split2 {re text} { - if {$text eq ""} { - return {} - } - set list [list] - set start 0 - - #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW - while {[regexp -start $start -indices -- $re $text match]} { - lassign $match matchStart matchEnd - #puts "->start $start ->match $matchStart $matchEnd" - if {$matchEnd < $matchStart} { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchStart] - incr start - } else { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] - set start [expr {$matchEnd+1}] - } - if {$start >= [tcl::string::length $text]} { - break - } - } - return [lappend list [tcl::string::range $text $start end]] - } - proc _perlish_split3 {re text} { - if {$text eq ""} { - return {} - } - set list [list] - set start 0 - - #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW - while {[regexp -start $start -indices -- $re $text match]} { - lassign $match matchStart matchEnd - #puts "->start $start ->match $matchStart $matchEnd" - if {$matchEnd < $matchStart} { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] - incr start - if {$start >= [tcl::string::length $text]} { - break - } - continue - } - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] - set start [expr {$matchEnd+1}] - #? - if {$start >= [tcl::string::length $text]} { - break - } - } - return [lappend list [tcl::string::range $text $start end]] - } - - #experiment for coroutine generator - proc _perlish_split_yield {re text} { - if {[tcl::string::length $text] == 0} { - yield {} - } - set list [list] - set start 0 - - #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW - while {[regexp -start $start -indices -- $re $text match]} { - lassign $match matchStart matchEnd - #puts "->start $start ->match $matchStart $matchEnd" - if {$matchEnd < $matchStart} { - yield [tcl::string::range $text $start $matchStart-1] - yield [tcl::string::index $text $matchStart] - incr start - if {$start >= [tcl::string::length $text]} { - break - } - continue - } - yield [tcl::string::range $text $start $matchStart-1] - yield [tcl::string::range $text $matchStart $matchEnd] - set start [expr {$matchEnd+1}] - #? - if {$start >= [tcl::string::length $text]} { - break - } - } - #return [lappend list [tcl::string::range $text $start end]] - yield [tcl::string::range $text $start end] - } - proc _ws_split {text} { - regexp -all -inline {(?:\S+)|(?:\s+)} $text - } - # -- --- --- --- --- --- - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}] -} -# -- --- --- --- --- --- --- --- --- --- --- -tcl::namespace::eval punk::ansi::class { - #assertions specifically for punk::ansi::class namespace - if {![llength [tcl::info::commands ::punk::ansi::class::assert]]} { - tcl::namespace::import ::punk::assertion::assert - punk::assertion::active 1 - } - - tcl::namespace::eval renderer { - if {[llength [tcl::info::commands ::punk::ansi::class::renderer::base_renderer]]} { - #Can happen if package forget was used and we're reloading (a possibly different version) ? review - ::punk::ansi::class::renderer::base_renderer destroy ;#will automatically destroy other classes such as class_cp437 that use this as a superclass - } - oo::class create base_renderer { - variable o_width - variable o_autowrap_mode - variable o_overflow o_appendlines o_looplimit - - variable o_cursor_column o_cursor_row - #variable o_render_index ;#index of input (from_ansistring) grapheme/ansi-code that *has* been rendered - variable o_rendereditems - - variable o_from_ansistring o_to_ansistring - variable o_ns_from o_ns_to ;#some dirty encapsulation violation as a 'friend' of ansistring objects - direct record of namespaces as they are frequently accessed - constructor {args} { - #-- make assert available -- - # By pointing it to the assert imported into ::punk::ansi::class - # (we could alternatively import assert *directly* from ::punk::assertion::assert - but we can't chain imports as setting active flag renames the command, breaking chained imports) - set nspath [tcl::namespace::path] - if {"::punk::ansi::class" ni $nspath} { - lappend nspath ::punk::ansi::class - } - tcl::namespace::path $nspath - #-- -- - if {[llength $args] < 1} { - error {usage: ?-width ? ?-height ? ?-autowrap_mode [1|0]? ?-overflow [1|0]? from_ansistring} - } - #lassign [lrange $args end-1 end] from_ansistring to_ansistring - set from_ansistring [lindex $args end] - - set opts [tcl::dict::create\ - -width \uFFEF\ - -height \uFFEF\ - -overflow 0\ - -appendlines 1\ - -looplimit 15000\ - -experimental {}\ - -cursor_column 1\ - -cursor_row 1\ - -insert_mode 0\ - -autowrap_mode 1\ - -initial_ansistring ""\ - ] - set argsflags [lrange $args 0 end-2] - foreach {k v} $argsflags { - switch -- $k { - -width - -height - - -overflow - -appendlines - -looplimit - -experimental - - -autowrap_mode - - -insert_mode - - -initial_ansistring { - tcl::dict::set opts $k $v - } - default { - #don't use [self class] - or we'll get the superclass - error "[info object class [self]] unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - set initial_ansistring [tcl::dict::get $opts -initial_ansistring] - if {$initial_ansistring eq ""} { - set to_ansistring [punk::ansi::class::class_ansistring new ""] - } else { - #todo - verify obj vs raw string - set to_ansistring $initial_ansistring - } - puts "[info object class [self]] renderer [self] constructor from ansistring $from_ansistring to ansistring $to_ansistring" - - set o_width [tcl::dict::get $opts -width] - set o_height [tcl::dict::get $opts -height] - set o_autowrap_mode [tcl::dict::get $opts -autowrap_mode] - set o_insert_mode [tcl::dict::get $opts -insert_mode] - set o_overflow [tcl::dict::get $opts -overflow] - set o_appendlines [tcl::dict::get $opts -appendlines] - set o_looplimit [tcl::dict::get $opts -looplimit] - set o_cursor_column [tcl::dict::get $opts -cursor_column] - set o_cursor_row [tcl::dict::get $opts -cursor_row] - - set o_from_ansistring $from_ansistring - set o_ns_from [info object namespace $o_from_ansistring] - set o_to_ansistring $to_ansistring - set o_ns_to [info object namespace $o_to_ansistring] - #set o_render_index -1 ;#zero based. -1 indicates nothing yet rendered. - set o_rendereditems [list] ;#graphemes + controls + individual ansi codes from input $o_from_ansistring - } - #temporary test method - method eval_in {script} { - eval $script - } - method renderbuf {} { - return $o_to_ansistring - } - method cursor_column {{col ""}} { - if {$col eq ""} { - return $o_cursor_column - } - if {$col < 1} { - error "Minimum cursor_column is 1" - } - set o_cursor_column $col - } - method cursor_row {{row ""}} { - if {$row eq ""} { - return $o_cursor_row - } - if {$row < 1} { - error "Minimum cursor_row is 1" - } - set o_cursor_row $row - } - - #set/query cursor state - method cursor_state {args} { - lassign $args r c - return [dict create row [my cursor_row $r] column [my cursor_column $c]] - } - - #consider scroll area - #we need to render to something with a concept of viewport, offscreen above,below,left,right? - method rendernext {} { - upvar ${o_ns_from}::o_ansisplits from_ansisplits - upvar ${o_ns_from}::o_elements from_elements - upvar ${o_ns_from}::o_splitindex from_splitindex - - #if {![llength $from_ansisplits]} {$o_from_ansistring eval_in {my MakeSplit}} ;#!!todo - a better way to keep this method semi hidden but call from a 'friend' - if {![llength $from_ansisplits]} { - tcl::namespace::eval $o_ns_from {my MakeSplit} - } - - set eidx [llength $o_rendereditems] - - #compare what we've rendered so far to our source to confirm they're still in sync - if {[lrange $o_rendereditems 0 $eidx-1] ne [lrange $from_elements 0 $eidx-1]} { - puts stdout "rendereditems 0->[expr {$eidx-1}]: [ansistring VIEW [lrange $o_rendereditems 0 $eidx-1]]" - puts stdout "from_elements 0->[expr {$eidx-1}]: [ansistring VIEW [lrange $from_elements 0 $eidx-1]]" - error "rendernext error - rendering state is out of sync. rendereditems list not-equal to corresponding part of ansistring $o_from_ansistring" - } - if {$eidx == [llength $from_elements]} { - #nothing new available - return [tcl::dict::create type "" rendercount 0 start_count_unrendered 0 end_count_unrendered 0] - } - - set start_elements_unrendered [expr {[llength $from_elements] - [llength $o_rendereditems]}] - #we need to render in pt code chunks - not each grapheme element individually - #translate from element index to ansisplits index - set process_splitindex [lindex $from_splitindex $eidx] ;#which from_ansisplits index the first unrendered element belongs to - - set elementinfo [lindex $from_elements $eidx] - lassign $elementinfo type_rendered item - #we don't expect type to change should be all graphemes (type 'g') or a single code (type 'sgr','other' etc) - #review - we may want to store more info for graphemes e.g g0 g1 g2 for zero-wide 1-wide 2-wide ? - #if so - we should report a list of the grapheme types that were rendered in a pt block - #as a counterpoint however - we don't currently retrieve grapheme width during split (performance impact at wrong time?) - and width may depend on the rendering method anyway - #e.g c0 controls are normally zero printing width - but are (often) 1-wide glyphs in a cp437 rendering operation. - - #we want to render all the elements in this splitindex - for pt this may be multiple, for code it will be a single element(?) - - set newtext "" - set rendercount 0 - if {$type_rendered eq "g"} { - - set e_splitindex $process_splitindex - while {$e_splitindex == $process_splitindex && $eidx < [llength $from_elements]} { - append newtext $item - lappend o_rendereditems $elementinfo - incr rendercount - - incr eidx - set e_splitindex [lindex $from_splitindex $eidx] - set elementinfo [lindex $from_elements $eidx] - lassign $elementinfo _type item - } - } else { - #while not g ? render however many ansi sequences are in a row? - set newtext $item - lappend o_rendereditems $elementinfo - incr rendercount - } - - set end_elements_unrendered [expr {[llength $from_elements] - [llength $o_rendereditems]}] - set count_rendered [expr {$start_elements_unrendered - $end_elements_unrendered}] - assert {$rendercount == $count_rendered} - - #todo - renderline equivalent that operates on already split data - - #we start with one inputchunk, but we get appends/inserts if the whole chunk isn't for a single line of output - set inputchunks [list $newtext] - if 0 { - while {[llength $inputchunks]} { - set overtext [lpop inputchunks 0] - if {![tcl::string::length $overtext]} { - continue - } - #set rinfo [overtype::renderline -info 1 -insert_mode 0 -autowrap_mode 1 -width $o_width -overflow 0 -cursor_column $col -cursor_row $row $undertext $overtext] - } - } - #renderspace equivalent? channel based? - #todo - $o_to_ansistring append $newtext - - return [tcl::dict::create type $type_rendered rendercount $rendercount start_count_unrendered $start_elements_unrendered end_count_unrendered $end_elements_unrendered] - } - - } - #name all with prefix class_ for rendertype detection - oo::class create class_cp437 { - superclass base_renderer - } - oo::class create class_editbuf { - superclass base_renderer - } - } - - if {[llength [tcl::info::commands ::punk::ansi::class::class_ansistring]]} { - ::punk::ansi::class::class_ansistring destroy - } - #As this is intended for column-based terminals - it has a different notion of string length, string index etc than for a plain string. - #oo names beginning with uppercase are private - so we can't use capitalisation as a hint to distinguish those which differ from Tcl semantics - oo::class create class_ansistring { - variable o_cksum_command o_string o_count - - #this is the main state we keep of the split apart string - #we use the punk::ansi::ta::split_codes_single function which produces a list with zero, or an odd number elements always beginning and ending with plaintext - variable o_ptlist ;#plaintext as list of elements from ansisplits - will include empty elements from between adjacent ansi-codes - variable o_ansisplits ;#store our plaintext/ansi-code splits so we don't keep re-running the regexp to split - - - #State regarding output renderstring (if any) - variable o_renderout ;#another class_ansistring instance - variable o_renderer ;# punk::ansi::class::renderer::class_ instance - variable o_renderwidth - variable o_rendertype - - # -- per element lookups -- - # llengths should all be the same - # we maintain 4 lookups per entry rather than a single nested list - # it is estimated that separate lists will be more efficient for certain operations - but that is open to review/testing. - variable o_elements ;#elements contains entry for each grapheme/control + each ansi code - variable o_sgrstacks ;#list of ansi sgr codes that will be merged later. Entries deliberately repeat if no change from previous entry. Later scans look for difference between n and n-1 when deciding where to apply codes. - variable o_gx0states ;#0|1 for alternate graphics gx0 - variable o_splitindex ;#entry for each element indicating the index of the split it belongs to. - # -- -- - - constructor {string} { - set o_string $string - - #-- make assert available -- - # By pointing it to the assert imported into ::punk::ansi::class - # (we could alternatively import assert *directly* from ::punk::assertion::assert - but we can't chain imports as setting active flag renames the command, breaking imports) - set nspath [tcl::namespace::path] - if {"::punk::ansi::class" ni $nspath} { - lappend nspath ::punk::ansi::class - } - tcl::namespace::path $nspath - #-- -- - - #we choose not to generate an internal split-state for the initial string - which may potentially be large. - #there are a few methods such as get, has_ansi, show_state,checksum that can run efficiently on the initial string without generating it. - #The length method can use ansi::ta::detect to work quickly without updating it if it can, and other methods also update it as necessary - - set o_count "" ;#o_count first updated when string appended or a method causes MakeSplit to run (or by count method if constructor argument was empty string) - - set o_ansisplits [list] ;#we get empty pt(plaintext) between each ansi code. Codes include cursor movements, resets,alt graphics modes, terminal mode settings etc. - set o_ptlist [list] - #o_ansisplits and o_ptlist should only remain empty if an empty string was passed to the contructor, or no methods have yet triggered the initial string to have it's internal state built. - - set o_elements [list] - set o_sgrstacks [list] - set o_gx0states [list] - set o_splitindex [list] - - #sha1 takes *much* longer to compute than md5 if tcllibc not available - otherwise it is generally faster - #we should fall back to md5 if no acceleration available. check for command sha1::sha1c ? - set o_cksum_command [list sha1::sha1 -hex] - - - #empty if no render methods used - # -- - set o_renderer "" - set o_renderout "" ;#class_ansistring - # -- - - set o_renderwidth 80 - set o_rendertype cp437 - } - - #temporary test method - method eval_in {script} { - eval $script - } - method checksum {} { - if {[catch { - package require sha1 - } errM]} { - error "sha1 package unavailable" - } - return [{*}$o_cksum_command [encoding convertto utf-8 $o_string]] - } - #todo - allow setting checksum algorithm and/or command - - method show_state {{verbose 0}} { - #show some state info - without updating anything - #only use 'my' methods that don't update the state e.g has_ansi - set result "" - if {![llength $o_ansisplits]} { - append result "No internal splits. " - append result \n "has ansi : [my has_ansi]" - append result \n "Tcl string length raw string: [tcl::string::length $o_string]" - } else { - append result \n "has ansi : [my has_ansi]" - append result \n "ansisplit list len: [llength $o_ansisplits]" - append result \n "plaintext list len: [llength $o_ptlist]" - append result \n "cached count : $o_count" - append result \n "Tcl string length raw string : [tcl::string::length $o_string]" - append result \n "Tcl string length plaintext parts: [tcl::string::length [join $o_ptlist ""]]" - if {[llength $o_ansisplits] %2 == 0} { - append result \n -------------------------------------------------- - append result \n Warning - ansisplits appears to be invalid length - append result \n Use show_state 1 to view - append result \n -------------------------------------------------- - } - } - if {$o_renderer ne ""} { - append result \n " renderer obj: $o_renderer" - append result \n " renderer class: [info object class $o_renderer]" - set renderstring [$o_renderer renderbuf] - append result \n " render target ansistring: $renderstring" - append result \n " render target has ansi : [$renderstring has_ansi]" - append result \n " render target count : [$renderstring count]" - } - if {$verbose} { - append result \n "ansisplits listing" - #we will use a foreach with a single var rather than foreach {pt code} - so that if something goes wrong it's clearer. - #(using foreach {pt code} on an odd element list will give a spurious empty code at the end) - set i 0 - foreach item $o_ansisplits { - if {$i % 2 == 0} { - set type "pt " - } else { - set type code - } - append result \n "$type: [ansistring VIEW $item]" - incr i - } - append result \n "Last element of ansisplits should be of type pt" - } - return $result - } - - #private method - method MakeSplit {} { - #The split with each code as it's own element is more generally useful. - set o_ansisplits [punk::ansi::ta::split_codes_single $o_string]; - set o_ptlist [list] - set codestack [list] - set gx0_state 0 ;#default off - set current_split_index 0 ;#incremented for each pt block, incremented for each code - if {$o_count eq ""} { - set o_count 0 - } - foreach {pt code} $o_ansisplits { - lappend o_ptlist $pt - foreach grapheme [punk::char::grapheme_split $pt] { - lappend o_elements [list g $grapheme] - lappend o_sgrstacks $codestack - lappend o_gx0states $gx0_state - lappend o_splitindex $current_split_index - incr o_count - } - #after handling the pt block - incr the current_split_index - incr current_split_index ;#increment for each pt block - whether empty string or not. Indices corresponding to empty PT blocks will therefore not be present in o_splitindex as there were no elements in that ansisplit entry - #we will only get an empty code at the very end of ansisplits (ansisplits is length 0 or odd length - always with pt at start and pt at end) - if {$code ne ""} { - lappend o_sgrstacks $codestack - lappend o_gx0states $gx0_state - lappend o_splitindex $current_split_index - - #maintenance warning - dup in append! - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list "\x1b\[m"] - lappend o_elements [list sgr $code] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - lappend o_elements [list sgr $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - lappend o_elements [list sgr $code] - } else { - if {[punk::ansi::codetype::is_gx_open $code]} { - set gx0_state 1 - lappend o_elements [list gx0 1] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } elseif {[punk::ansi::codetype::is_gx_close $code]} { - set gx0_state 0 - lappend o_elements [list gx0 0] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } else { - lappend o_elements [list other $code] - } - } - #after each code (ignoring bogus empty final due to foreach with 2 vars on odd-length list) increment the current_split_index - incr current_split_index - } - } - #assertion every grapheme and every individual code has been added to o_elements - #every element has an entry in o_sgrstacks - #every element has an entry in o_gx0states - assert {[llength $o_elements] == [llength $o_sgrstacks] && [llength $o_elements] == [llength $o_gx0states] && [llength $o_elements] == [llength $o_splitindex]} - } - method convert_altg {} { - #do we need a method to retrieve without converting in the object? - puts "unimplemented" - } - method strippedlength {} { - if {![llength $o_ansisplits]} {my MakeSplit} - #review - return [string length [join $o_ptlist ""]] - } - #returns the ansiless string - doesn't affect the stored state other than initialising it's internal state if it wasn't already - method stripped {} { - if {![llength $o_ansisplits]} {my MakeSplit} - return [join $o_ptlist ""] - } - - #does not affect object state - #REVIEW - icu or equiv required - method DoCount {plaintext} { - #- combiners/diacritics just map them away here - but for consistency we need to combine unicode grapheme clusters too. - #todo - joiners 200d? zwnbsp - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} - - #we want length to return number of glyphs + normal controls such as newline.. not screen width. Has to be consistent with index function - return [tcl::string::length [regsub -all $re_diacritics $plaintext ""]] - } - - #This is the count of visible graphemes + non-ansi control chars. Not equal to column width or to the Tcl string length of the ansistripped string!!! - method count {} { - if {$o_count eq ""} { - #only initial string present - if {$o_string eq ""} { - set o_count 0 - return 0 - } - my MakeSplit - #set o_count [my DoCount [join $o_ptlist ""]] - } - return $o_count - } - #this is the equivalent of Tcl string length on the ansistripped string - method length {} { - if {![llength $o_ansisplits]} { - if {[punk::ansi::ta::detect $o_string]} { - my MakeSplit - } else { - return [tcl::string::length $o_string] - } - } elseif {[llength $o_ansisplits] == 1} { - #single split always means no ansi - return [tcl::string::length $o_string] - } - return [tcl::string::length [join $o_ptlist ""]] - } - method length_raw {} { - return [tcl::string::length $o_string] - } - - #channels for stream in/out.. these are vaguely analogous to the input/output between a shell and a PTY Slave - but this is not intended to be a full pseudoterminal - #renderstream_to_render (private?) - # write end held by outer ansistring? read end by inner render ansistring ? - #renderstream_from_render (public?) - - method rendertypes {} { - set classes [tcl::info::commands ::punk::ansi::class::renderer::class_*] - #strip off class_ - set ctypes [lmap v $classes {tcl::string::range [tcl::namespace::tail $v] 6 end}] - } - method rendertype {{rtype ""}} { - if {$rtype eq ""} { - return $o_rendertype - } - set rtypes [my rendertypes] - if {$rtype ni $rtypes} { - error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)" - } - #if {$o_renderout eq ""} { - # set o_renderout [punk::ansi::class::class_ansistring new ""] - #} - if {$o_renderer ne ""} { - set oinfo [info object class $o_renderer] - set tail [tcl::namespace::tail $oinfo] - set currenttype [tcl::string::range $tail 6 end] - if {$rtype ne $currenttype} { - puts "switch rendertype from $currenttype to $rtype - destroying renderer and creating a new one" - $o_renderer destroy ;#what happens to data in target ansistring obj? when does it make sense to keep output and keep rendering vs clearing? - #set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout] - set o_renderer [punk::ansi::class::renderer::class_$rtype new [self]] - } else { - return $currenttype - } - } else { - puts "creating first renderer" - #set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout] - set o_renderer [punk::ansi::class::renderer::class_$rtype new [self]] - } - } - #--- progressive rendering buffer - another ansistring object - method renderwidth {{rw ""}} { - #report or set the renderwidth - may invalidate existing render progress? restart? - if {$rw eq ""} { - return $o_renderwidth - } - if {$rw eq $o_renderwidth} { - return $o_renderwidth - } - #re-render if needed? - puts stderr "renderwidth todo? re-render?" - - set o_renderwidth $rw - } - method renderer {} { - return $o_renderer - } - method render_state {} { - #? report state of render.. we will primarily be using plaintext/ansisequence as the chunk/operation boundary - #but - as we can append char sequences directly to the tail split - it's not enough to track which split element we have rendered - but we also need how many graphemes or code sequences we are into the last split. - #A single number representing the count of graphemes and individual ANSI codes (from the input ansistring) rendered might work - } - method renderbuf {} { - #get the underlying renderobj - if any - #return $o_renderout ;#also class_ansistring - if {$o_renderer eq ""} {error "renderbuf error: no active renderer"} - return [$o_renderer renderbuf] - } - method render {{maxgraphemes ""}} { - #full render - return buffer ansistring - set do_render 1 - set grapheme_count 0 - set other_count 0 - if {$maxgraphemes eq ""} { - while {$do_render} { - set rendition [my rendernext] - set do_render [dict get $rendition rendercount] - if {[dict get $rendition type] eq "g"} { - incr grapheme_count $do_render - } else { - incr other_count $do_render - } - } - } else { - while {$do_render && $grapheme_count <= $maxgraphemes} { - set rendition [my rendernext] - set do_render [dict get $rendition rendercount] - if {[dict get $rendition type] eq "g"} { - incr grapheme_count $do_render - } else { - incr other_count $do_render - } - } - } - return [dict create graphemes $grapheme_count other $other_count] - } - method rendernext {} { - #render next available pt/code chunk only - not to end of available input - if {$o_renderer eq ""} { - my rendertype $o_rendertype ;#review - proper way to initialise rendering - } - $o_renderer rendernext - } - method render_cursorstate {{row_x_col ""}} { - #report /set? cursor posn - if {$o_renderer eq ""} { - error "No renderer. Call render methods first" - } - return [tcl::dict::create row [$o_renderer cursor_row] column [$o_renderer cursor_column]] - } - #--- - - method get {} { - return $o_string - } - method has_ansi {} { - if {![llength $o_ansisplits]} { - #initial string - for large strings,it's faster to run detect than update the internal split-state. - return [punk::ansi::ta::detect $o_string] - } else { - #string will continue to have a single o_ansisplits element if only non-ansi appended - return [expr {[llength $o_ansisplits] != 1}] - } - } - #todo - has_ansi_movement ? - #If an arbirary ANSI string has movement/cursor restore - then the number of apparent rows in the input will potentially bear no relation to the number of lines of output. - #i.e a 'rendered' ANSI string should contain just ANSI SGR character attributes and linefeeds for rows - #Knowing which is which can be helpful as far as use of any methods which use the concepts of terminal row/column - - #like Tcl's append class_ansistring append returns the result directly - which for ANSI - can be inconvenient in the terminal - #class_ansistring append_string is a convenience wrapper to avoid returning the raw result - method append_string {args} { - my append {*}$args - return - } - - #analagous to Tcl string append - #MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient - method append {args} { - set catstr [join $args ""] - if {$catstr eq ""} { - return $o_string - } - - if {![punk::ansi::ta::detect $catstr]} { - #ansi-free additions - #if no initial internal-split - generate it without first appending our additions - as we can more efficiently append them to the internal state - if {![llength $o_ansisplits]} { - #initialise o_count because we need to add to it. - #The count method will do this by calling Makesplit only if it needs to. (which will create ansisplits for anything except empty string) - my count - } - append o_string $catstr;# only append after updating using my count above - if {![llength $o_ptlist]} { - #If the object was initialised with empty string - we can still have empty lists for o_ptlist and o_ansisplits - #even though we can use lset to add to a list - we can't for empty - lappend o_ptlist $catstr - #assertion - if o_ptlist is empty so is o_ansisplits - lappend o_ansisplits $catstr - } else { - lset o_ptlist end [tcl::string::cat [lindex $o_ptlist end] $catstr] - lset o_ansisplits end [tcl::string::cat [lindex $o_ansisplits end] $catstr] - } - set last_codestack [lindex $o_sgrstacks end] - set last_gx0state [lindex $o_gx0states end] - set current_split_index [expr {[llength $o_ansisplits]-1}] ;#we are attaching to existing trailing pt - use its splitindex - foreach grapheme [punk::char::grapheme_split $catstr] { - lappend o_elements [list g $grapheme] - lappend o_sgrstacks $last_codestack - lappend o_gx0states $last_gx0state - lappend o_splitindex $current_split_index - incr o_count - } - #incr o_count [my DoCount $catstr] ;#from before we were doing grapheme split.. review - } else { - if {![llength $o_ansisplits]} { - #if we have an initial string - but no internal split-state because this is our first append and no methods have caused its generation - we can run more efficiently by combining it with the first append - append o_string $catstr ;#append before split and count on whole lot - my MakeSplit ;#update o_count - #set combined_plaintext [join $o_ptlist ""] - #set o_count [my DoCount $combined_plaintext] - assert {[llength $o_elements] == [llength $o_sgrstacks] && [llength $o_elements] == [llength $o_gx0states] && [llength $o_elements] == [llength $o_splitindex]} - return $o_string - } else { - #update each element of internal state incrementally without reprocessing what is already there. - append o_string $catstr - set newsplits [punk::ansi::ta::split_codes_single $catstr] - set ptnew "" - set codestack [lindex $o_sgrstacks end] - set gx0_state [lindex $o_gx0states end] - set current_split_index [lindex $o_splitindex end] - #first pt must be merged with last element of o_ptlist - set new_pt_list [list] - foreach {pt code} $newsplits { - lappend new_pt_list $pt - append ptnew $pt - foreach grapheme [punk::char::grapheme_split $pt] { - lappend o_elements [list g $grapheme] - lappend o_sgrstacks $codestack - lappend o_gx0states $gx0_state - lappend o_splitindex $current_split_index - incr o_count - } - incr current_split_index ;#increment 1 of 2 within each loop - if {$code ne ""} { - lappend o_sgrstacks $codestack - lappend o_gx0states $gx0_state - lappend o_splitindex $current_split_index - #maintenance - dup in MakeSplit! - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list "\x1b\[m"] - lappend o_elements [list sgr $code] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - lappend o_elements [list sgr $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - lappend o_elements [list sgr $code] - } else { - if {[punk::ansi::codetype::is_gx_open $code]} { - set gx0_state 1 - lappend o_elements [list gx0 1] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } elseif {[punk::ansi::codetype::is_gx_close $code]} { - set gx0_state 0 - lappend o_elements [list gx0 0] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } else { - lappend o_elements [list other $code] - } - } - incr current_split_index ;#increment 2 of 2 - } - } - lset o_ptlist end [tcl::string::cat [lindex $o_ptlist end] [lindex $new_pt_list 0]] - lappend o_ptlist {*}[lrange $new_pt_list 1 end] - lset o_ansisplits end [tcl::string::cat [lindex $o_ansisplits end] [lindex $newsplits 0]] - lappend o_ansisplits {*}[lrange $newsplits 1 end] - - #if {$o_count eq ""} { - # #we have splits - but didn't count graphemes? - # set o_count [my DoCount [join $o_ptlist ""]] ;#o_ptlist already has ptnew parts - #} else { - # incr o_count [my DoCount $ptnew] - #} - - } - } - assert {[llength $o_elements] == [llength $o_sgrstacks] && [llength $o_elements] == [llength $o_gx0states] && [llength $o_elements] == [llength $o_splitindex]} - return $o_string - } - - #we are currently assuming that the component strings have complete graphemes ie no split clusters - and therefore we don't attempt to check for and combine at the string catenation points. - #This is 'often'? likely to be true - We don't have grapheme cluster support yet anyway. review. - method appendobj {args} { - if {![llength $o_ansisplits]} { - my MakeSplit - } - foreach a $args { - set ns [info object namespace $a] - upvar ${ns}::o_ansisplits new_ansisplits - upvar ${ns}::o_count new_count - if {![llength $new_ansisplits] || $new_count eq ""} { - tcl::namespace::eval $ns {my MakeSplit} - } - upvar ${ns}::o_ptlist new_ptlist - upvar ${ns}::o_string new_string - upvar ${ns}::o_elements new_elements - upvar ${ns}::o_sgrstacks new_sgrstacks - upvar ${ns}::o_gx0states new_gx0states - upvar ${ns}::o_splitindex new_splitindex - - lset o_ansisplits end [tcl::string::cat [lindex $o_ansisplits end] [lindex $new_ansisplits 0]] - lappend o_ansisplits {*}[lrange $new_ansisplits 1 end] - lset o_ptlist end [tcl::string::cat [lindex $o_ptlist end] [lindex $new_ptlist 0]] - lappend o_ptlist {*}[lrange $new_ptlist 1 end] - - append o_string $new_string - lappend o_elements {*}$new_elements - - #prepend the previous sgr stack to all stacks in the new list. - #This allows us to use only list operations to keep the sgr data valid - but we don't yet make it canonical/flat by examining each for resets etc. - #ie just call sgr_merge_list once now. - set laststack [lindex $o_sgrstacks end] - set mergedtail [punk::ansi::codetype::sgr_merge_list "" {*}$laststack] - foreach n $new_sgrstacks { - lappend o_sgrstacks [list $mergedtail {*}$n] - } - - - lappend o_gx0states {*}$new_gx0states - - #first and last of ansisplits splits merge - set lastidx [lindex $o_splitindex end] - set firstnewidx [lindex $new_splitindex 0] - set diffidx [expr {$lastidx - $firstnewidx}] ;#may be negative - foreach v $new_splitindex { - lappend o_splitindex [expr {$v + $diffidx}] - } - - incr o_count $new_count - } - return $o_count - } - - - #method append_and_render? - append and render up to end of appended data at same time - - method view {args} { - if {$o_string eq ""} { - return "" - } - #ansistring VIEW relies only on the raw ansi input as it is essentially just a tcl::string::map. - #We don't need to force an ansisplit if we happen to have an unsplit initial string - ansistring VIEW $o_string - } - method viewcodes {args} { - if {$o_string eq ""} { - return "" - } - if {![llength $o_ansisplits]} {my MakeSplit} - - set redb [a+ red bold] ;#osc/apm ? anything with potential security risks or that is unusual - set greenb [a+ green bold] ;#SGR - set cyanb [a+ cyan bold] ;#col,row movement - set blueb [a+ blue bold] ;# - set blueb_r [a+ blue bold reverse] - set whiteb [a+ white bold] ;#SGR reset (or highlight first part if leading reset) - set GX [a+ black White bold] ;#alt graphics - set unk [a+ yellow bold] ;#unknown/unhandled - set RST [a] - - set re_col_move {\x1b\[([0-9]*)(C|D|G)$} - set re_row_move {\x1b\[([0-9]*)(A|B)$} - set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} - set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} - set re_cursor_save {\x1b\[s$} - set re_cursor_restore {\x1b\[u$} - set re_cursor_save_dec {\x1b7$} - set re_cursor_restore_dec {\x1b8$} - - set arrow_left \u2190 - set arrow_right \u2192 - set arrow_up \u2191 - set arrow_down \u2193 - set arrow_lr \u2194 - set arrow_du \u2195 - #2024 - there is no 4-arrow symbol or variations (common cursor and window icon) in unicode - despite requests and argument from the community that this has been in use for decades. - #They are probably too busy with stupid emoji additions to add this or c1 visualization glyphs. - - #don't split into lines first - \n is valid within ST sections - set output "" - #set splits [punk::ansi::ta::split_codes_single $string] - - foreach {pt code} $o_ansisplits { - append output [ansistring VIEW {*}$args $pt] - - #map DEC cursor_save/restore to CSI version - set code [tcl::string::map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $code] - - - set c1 [tcl::string::index $code 0] - set c1c2 [tcl::string::range $code 0 1] - #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\] 7OSC\ - \x1b\( 7GFX\ - \x9d 8OSC\ - \x1b 7ESC\ - ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars - - #we leave the tail of the code unmapped for now - switch -- $leadernorm { - 7CSI - 7OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] - } - 7ESC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - 8CSI - 8OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - default { - #we haven't made a mapping for this - set codenorm $code - } - } - - switch -- $leadernorm { - {7CSI} - {8CSI} { - set param [tcl::string::range $codenorm 4 end-1] - #puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param" - switch -- [tcl::string::index $codenorm end] { - m { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set displaycode [ansistring VIEW $code] - append output ${whiteb}$displaycode$RST - } else { - set displaycode [ansistring VIEW $code] - if {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - #highlight the esc & leftbracket in white as indication there is a leading reset - set cposn [tcl::string::first ";" $displaycode] - append output ${whiteb}[tcl::string::range $displaycode 0 $cposn]$RST${greenb}[tcl::string::range $displaycode $cposn+1 end]$RST - } else { - append output ${greenb}$displaycode$RST - } - } - } - A - B { - #row move - set displaycode [ansistring VIEW $code] - set displaycode [tcl::string::map [list A "A$arrow_up" B "B$arrow_down"] $displaycode] - append output ${cyanb}$displaycode$RST - - } - C - D - G { - #set num [tcl::string::range $codenorm 4 end-1] - set displaycode [ansistring VIEW $code] - set displaycode [tcl::string::map [list C "C$arrow_right" D "D$arrow_left" G "G$arrow_lr"] $displaycode] - append output ${cyanb}$displaycode$RST - } - H - f { - set params [tcl::string::range $codenorm 4 end-1] - lassign [split $params {;}] row col - #lassign $matchinfo _match row col - set displaycode [ansistring VIEW $code] - if {$col eq ""} { - #row only move - set map [list H "H${arrow_lr}" f "f${arrow_lr}"] - } else { - #row and col move - set map [list H "H${arrow_lr}${arrow_du}" f "${arrow_lr}${arrow_du}"] - } - set displaycode [tcl::string::map $map $displaycode] - append output ${cyanb}$displaycode$RST - } - s { - append output ${blueb}[ansistring VIEW $code]$RST - } - u { - append output ${blueb_r}[ansistring VIEW $code]$RST - } - default { - append output ${unk}[ansistring VIEW -lf 1 $code]$RST - } - } - } - 7GFX { - switch -- [tcl::string::index $codenorm 4] { - "0" { - append output ${GX}GX+$RST - } - "B" { - append output ${GX}GX-$RST - } - } - } - 7ESC { - append output ${unk}[ansistring VIEW -lf 1 $code]$RST - } - default { - #if the code is a PM (or other encapsulation type code e.g terminated by ST) we want to see linefeeds as visual representation character - append output ${unk}[ansistring VIEW -lf 1 $code]$RST - } - } - - } - return $output - } - - method viewstyle {args} { - if {$o_string eq ""} { - return "" - } - if {![llength $o_ansisplits]} {my MakeSplit} - - #set splits [punk::ansi::ta::split_codes_single $string] - set output "" - set codestack [list] - set gx_stack [list] ;#not actually a stack - set cursor_saved "" - foreach {pt code} $o_ansisplits { - if {[llength $args]} { - set pt [ansistring VIEW {*}$args $pt] - } - append output [punk::ansi::codetype::sgr_merge_list {*}$codestack]$pt - if {$code ne ""} { - append output [a][ansistring VIEW -lf 1 $code] - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #basic simplification first.. straight dups - set dup_posns [lsearch -all -exact $codestack $code] ;#-exact because of square-bracket glob chars - #lremove not present in pre 8.7! - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } elseif {[regexp {\x1b7|\x1b\[s} $code]} { - #cursor_save - set cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$codestack] - } elseif {[regexp {\x1b8|\x1b\[u} $code]} { - #cursor_restore - set codestack [list $cursor_saved] - } else { - #leave SGR stack as is - if {[punk::ansi::codetype::is_gx_open $code]} { - set gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess - } elseif {[punk::ansi::codetype::is_gx_close $code]} { - set gx_stack [list] - } - } - } - } - return $output - - } - } -} -tcl::namespace::eval punk::ansi { - - proc stripansi3 {text} [string map [list $::punk::ansi::ta::re_ansi_split] { - - #using detect costs us a couple of uS - but saves time on plain text - #we should probably leave this for caller - otherwise it ends up being called more than necessary - #if {![::punk::ansi::ta::detect $text]} { - # return $text - #} - - #alternate graphics codes are not the norm - # - so save a few uS in the common case by only calling convert_g0 if we detect - if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters - } - punk::ansi::ta::Do_split_at_codes_join $text {} - }] - - proc stripansiraw3 {text} [string map [list $::punk::ansi::ta::re_ansi_split] { - - #join [::punk::ansi::ta::split_at_codes $text] "" - punk::ansi::ta::Do_split_at_codes_join $text {} - }] -} - -tcl::namespace::eval punk::ansi::ansistring { - #*** !doctools - #[subsection {Namespace punk::ansi::ansistring}] - #[para]punk::ansi::ansistring ensemble - ansi-aware string operations - #[para]Working with strings containing ansi in a way that preserves/understands the codes is always going to be significantly slower than working with plain strings - #[para]Just as working with other forms of markup such as HTML - you simply need to be aware of the tradeoffs and design accordingly. - #[list_begin definitions] - - tcl::namespace::path [list ::punk::ansi ::punk::ansi::ta] - tcl::namespace::ensemble create - tcl::namespace::export length trim trimleft trimright INDEX COUNT VIEW VIEWCODES VIEWSTYLE INDEXABSOLUTE INDEXCOLUMNS COLUMNINDEX NEW - #todo - expose _splits_ methods so caller can work efficiently with the splits themselves - #we need to consider whether these can be agnostic towards splits from split_codes vs split_codes_single - - #\UFFFD - replacement char or \U2426 - - #using ISO 2047 graphical representations of control characters - probably obsolete? - #00 NUL Null ⎕ U+2395 NU - #01 TC1, SOH Start of Heading ⌈ U+2308 SH - #02 TC2, STX Start of Text ⊥ U+22A5 SX - #03 TC3, ETX End of Text ⌋ U+230B EX - #04 TC4, EOT End of Transmission ⌁ U+2301[9] ET - #05 TC5, ENQ Enquiry ⊠[a] U+22A0 EQ - #06 TC6, ACK Acknowledge ✓ U+2713 AK - #07 BEL Bell ⍾ U+237E[9] BL - #08 FE0, BS Backspace ⤺ —[b] BS - #09 FE1, HT Horizontal Tabulation ⪫ U+2AAB HT - #0A FE2, LF Line Feed ≡ U+2261 LF - #0B FE3, VT Vertical Tabulation ⩛ U+2A5B VT - #0C FE4, FF Form Feed ↡ U+21A1 FF - #0D FE5, CR Carriage Return ⪪ U+2AAA CR - #0E SO Shift Out ⊗ U+2297 SO - #0F SI Shift In ⊙ U+2299 SI - #10 TC7, DLE Data Link Escape ⊟ U+229F DL - #11 DC1, XON, CON[10] Device Control 1 ◷ U+25F7 D1 - #12 DC2, RPT,[10] TAPE[c] Device Control 2 ◶ U+25F6 D2 - #13 DC3, XOF, XOFF Device Control 3 ◵ U+25F5 D3 - #14 DC4, COF, KMC,[10] TAPE[c] Device Control 4 ◴ U+25F4 D4 - #15 TC8, NAK Negative Acknowledge ⍻ U+237B[9] NK - #16 TC9, SYN Synchronization ⎍ U+238D SY - #17 TC10, ETB End of Transmission Block ⊣ U+22A3 EB - #18 CAN Cancel ⧖ U+29D6 CN - #19 EM End of Medium ⍿ U+237F[9] EM - #1A SUB Substitute Character ␦ U+2426[12] SB - #1B ESC Escape ⊖ U+2296 EC - #1C IS4, FS File Separator ◰ U+25F0 FS - #1D IS3, GS Group Separator ◱ U+25F1 GS - #1E IS2, RS Record Separator ◲ U+25F2 RS - #1F IS1 US Unit Separator ◳ U+25F3 US - #20 SP Space △ U+25B3 SP - #7F DEL Delete ▨ —[d] DT - - #C0 control code visual representations - # Code Val Name 2X Description - # 2400 00 NUL NU Symbol for Null - # 2401 01 SOH SH Symbol for Start of Heading - # 2402 02 STX SX Symbol for Start of Text - # 2403 03 ETX EX Symbol for End of Text - # 2404 04 EOT ET Symbol for End of Transmission - # 2405 05 ENQ EQ Symbol for Enquiry - # 2406 06 ACK AK Symbol for Acknowledge - # 2407 07 BEL BL Symbol for Bell - # 2409 09 BS BS Symbol for Backspace - # 2409 09 HT HT Symbol for Horizontal Tab (1) - # 240A 0A LF LF Symbol for Line Feed (1) - # 240B 0B VT VT Symbol for Vertical Tab (1) - # 240C 0C FF FF Symbol for Form Feed (2) - # 240D 0D CR CR Symbol for Carriage Return (1) - # 240E 0E SO SO Symbol for Shift Out - # 240F 0F SI SI Symbol for Shift In - # 2410 10 DLE DL Symbol for Data Link Escape - # 2411 11 DC1 D1 Symbol for Device Control 1 (2) - # 2412 12 DC2 D2 Symbol for Device Control 2 (2) - # 2413 13 DC3 D3 Symbol for Device Control 3 (2) - # 2414 14 DC4 D4 Symbol for Device Control 4 (2) - # 2415 15 NAK NK Symbol for Negative Acknowledge - # 2416 16 SYN SY Symbol for Synchronous Idle - # 2417 17 ETB EB Symbol for End of Transmission Block - # 2418 18 CAN CN Symbol for Cancel - # 2419 19 EM EM Symbol for End of Medium - # 241A 1A SUB SU Symbol for Substitute - # 241B 1B ESC EC Symbol for Escape - # 241C 1C FS FS Symbol for Field Separator (3) - # 241D 1D GS GS Symbol for Group Separator (3) - # 241E 1E RS RS Symbol for Record Separator (3) - # 241F 1F US US Symbol for Unit Separator (3) - # 2420 20 SP SP Symbol for Space (4) - # 2421 7F DEL DT Symbol for Delete (4) - - #C1 control code visual representations - #Code Val Name 2X Description - # 80 80 80 (1) - # 81 81 81 (1) - # E022 82 BPH 82 Symbol for Break Permitted Here (2) - # E023 83 NBH 83 Symbol for No Break Here (2) - # E024 84 IND IN Symbol for Index (3) - # E025 85 NEL NL Symbol for Next Line (4) - # E026 86 SSA SS Symbol for Start Selected Area - # E027 87 ESA ES Symbol for End Selected Area - # E028 88 HTS HS Symbol for Character Tabulation Set - # E029 89 HTJ HJ Symbol for Character Tabulation with Justification - # E02A 8A VTS VS Symbol for Line Tabulation Set - # E02B 8B PLD PD Symbol for Partial Line Forward - # E02C 8C PLU PU Symbol for Partial Line Backward - # E02D 8D RI RI Symbol for Reverse Line Feed - # E02E 8E SS2 S2 Symbol for Single Shift 2 - # E02F 8F SS3 S3 Symbol for Single Shift 3 - # E030 90 DCS DC Symbol for Device Control String - # E031 91 PU1 P1 Symbol for Private Use 1 - # E032 92 PU2 P2 Symbol for Private Use 2 - # E033 93 STS SE Symbol for Set Transmit State - # E034 94 CCH CC Symbol for Cancel Character - # E035 95 MW MW Symbol for Message Waiting - # E036 96 SPA SP Symbol for Start Protected (Guarded) Area - # E037 97 EPA EP Symbol for End Protected (Guarded) Area - # E038 98 SOS 98 Symbol for Start of String (2) - # 99 99 (1) - # E03A 9A SCI 9A Symbol for Single Character Introducer (2) - # E03B 9B CSI CS Symbol for Control Sequence Introducer (5) - # E03C 9C ST ST Symbol for String Terminator - # E03D 9D OSC OS Symbol for Operating System Command - # E03E 9E PM PM Symbol for Privacy Message - # E03F 9F APC AP Symbol for Application Program Command - - variable debug_visuals - #modern (c0 seem to have more terminal/font support - C1 can show 8bit c1 codes - but also seems to be limited support) - - #Goal is not to map every control character? - #Map of which elements we want to convert - done this way so we can see names of control's that are included: - ease of maintenance compared to just creating the tcl::string::map directly - #ETX -ctrl-c - #EOT ctrl-d (EOF?) - #SYN ctrl-v - #SUB ctrl-z - #CAN ctrl-x - #FS ctrl-\ (SIGQUIT) - set visuals_interesting [tcl::dict::create\ - NUL [list \x00 \u2400]\ - ETX [list \x03 \u2403]\ - EOT [list \x04 \u2404]\ - BEL [list \x07 \u2407]\ - SYN [list \x16 \u2416]\ - CAN [list \x18 \u2418]\ - SUB [list \x1a \u241a]\ - FS [list \x1c \u241c]\ - SOS [list \x98 \ue038]\ - CSI [list \x9b \ue03b]\ - ST [list \x9c \ue03c]\ - PM [list \x9e \ue03e]\ - APC [list \x9f \ue03f]\ - ] - #it turns out we need pretty much everything for debugging - set visuals_c0 [tcl::dict::create\ - NUL [list \x00 \u2400]\ - SOH [list \x01 \u2401]\ - STX [list \x02 \u2402]\ - ETX [list \x03 \u2403]\ - EOT [list \x04 \u2404]\ - ENQ [list \x05 \u2405]\ - ACK [list \x06 \u2406]\ - BEL [list \x07 \u2407]\ - BS [list \x08 \u2408]\ - HT [list \x09 \u2409]\ - LF [list \x0a \u240a]\ - VT [list \x0b \u240b]\ - FF [list \x0c \u240c]\ - CR [list \x0d \u240d]\ - SO [list \x0e \u240e]\ - SF [list \x0f \u240f]\ - DLE [list \x10 \u2410]\ - DC1 [list \x11 \u2411]\ - DC2 [list \x12 \u2412]\ - DC3 [list \x13 \u2413]\ - DC4 [list \x14 \u2414]\ - NAK [list \x15 \u2415]\ - SYN [list \x16 \u2416]\ - ETB [list \x17 \u2417]\ - CAN [list \x18 \u2418]\ - EM [list \x19 \u2419]\ - SUB [list \x1a \u241a]\ - ESC [list \x1b \u241b]\ - FS [list \x1c \u241c]\ - GS [list \x1d \u241d]\ - RS [list \x1e \u241e]\ - US [list \x1f \u241f]\ - SP [list \x20 \u2420]\ - DEL [list \x7f \u2421]\ - ] - set map_c0 [dict create] - dict for {k v} $visuals_c0 { - dict set map_c0 {*}$v - } - - #alternate symbols for space - # \u2422 Blank Symbol (b with forwardslash overly) - # \u2423 Open Box (square bracket facing up like a tray/box) - - # \u2424 Symbol for Newline (small "NL") - - # \u2425 Symbol for Delete Form Two (some sort of fat forward-slash thing) - - # \u2426 Symbol for Substitute Form Two (backwards question mark) - - #these are in the PUA (private use area) unicode block - seem to be rarely supported - #the unicode consortium has apparently neglected to provide separate visual representation codepoints for not only the c1 controls (some of which ARE still used e.g in sixels) but various other non-printing chars such as BOM - #The debugging/analysis usecase is an important one - surely moreso that some of the emoji stuff coming out of there. - #we'll hack in some stuff as needed - may override some of the visuals_c1 which is usually just empty/substitute glyphs - #Being repurposed - these could potentially be confused with actual characters depending on the debugging context - #To minimize potential confusion - we'll use a longer replacement sequence - which is not ideal from the perspective of terminal column layout debugging - #A single unique glyph would be better - although the bracketing for 8-bit codes is a useful visual indicator - #(review - BOM should use different brackets to c1?) - - #todo - regularly check if unicode has improved in this area - though with requests for c1 visuals dating back to at least 2011 - it's doubtful. - #for 8-bit controls - we will standardize on a fixed width of 4 bracketing with: - #\u2987 and \u2988 from Miscellaneous Mathematical Symbols-B (D or fractional-moon shaped brackets) - #\u2987 - Z Notation Left Image Bracket - #\u2988 - Z Notation Right Image Bracket - #selection of these is also based on them being seemingly reasonably widely available in fonts.. review - #my apologies if you're debugging z-notation strings! - #If only column's-worth of symbol/char needed between the brackets - pad with a space before the closing bracket - - #8-bit brackets - set ob8 \u2987; set cb8 \u2988 ;#z-notation image brackets - - #miscellaneous debug code brackets - set obm \u27e6 ;set cbm \u27e7 ;#square double brackets from Miscellaneous Mathematical Symbols-A - - #unicode Tags block brackets - set obt \u2993 ;set cbt \u2994 - - #this private range so rarely supported in fonts - and visuals are unknown, so we will make up some 2-letter codes for now - #set visuals_c1 [tcl::dict::create\ - # BPH [list \x82 "${ob8}\ue022 $cb8"]\ - # NBH [list \x83 "${ob8}\ue023 $cb8"]\ - # IND [list \x84 "${ob8}\ue024 $cb8"]\ - # NEL [list \x85 "${ob8}\ue025 $cb8"]\ - # SSA [list \x86 "${ob8}\ue026 $cb8"]\ - # ESA [list \x87 "${ob8}\ue027 $cb8"]\ - # HTS [list \x88 "${ob8}\ue028 $cb8"]\ - # HTJ [list \x89 "${ob8}\ue029 $cb8"]\ - # VTS [list \x8a "${ob8}\ue02a $cb8"]\ - # PLD [list \x8b "${ob8}\ue02a $cb8"]\ - # PLU [list \x8c "${ob8}\ue02c $cb8"]\ - # RI [list \x8d "${ob8}\ue02d $cb8"]\ - # SS2 [list \x8e "${ob8}\ue02e $cb8"]\ - # SS3 [list \x8f "${ob8}\ue02f $cb8"]\ - # DCS [list \x90 "${ob8}\ue030 $cb8"]\ - # PU1 [list \x91 "${ob8}\ue031 $cb8"]\ - # PU2 [list \x92 "${ob8}\ue032 $cb8"]\ - # STS [list \x93 "${ob8}\ue033 $cb8"]\ - # CCH [list \x94 "${ob8}\ue034 $cb8"]\ - # MW [list \x95 "${ob8}\ue035 $cb8"]\ - # SPA [list \x96 "${ob8}\ue036 $cb8"]\ - # EPA [list \x97 "${ob8}\ue037 $cb8"]\ - # SOS [list \x98 "${ob8}\ue038 $cb8"]\ - # SCI [list \x9a "${ob8}\ue03a $cb8"]\ - # CSI [list \x9b "${ob8}\ue03b $cb8"]\ - # ST [list \x9c "${ob8}\ue03c $cb8"]\ - # OSC [list \x9d "${ob8}\ue03d $cb8"]\ - # PM [list \x9e "${ob8}\ue03e $cb8"]\ - # APC [list \x9f "${ob8}\ue03f $cb8"]\ - #] - - #these 2 letter codes only need to disambiguate within the c1 set - they're not great. - #these sit within the Latin-1 Supplement block - set visuals_c1 [tcl::dict::create\ - PAD [list \x80 "${ob8}PD$cb8"]\ - HOP [list \x81 "${ob8}HP$cb8"]\ - BPH [list \x82 "${ob8}BP$cb8"]\ - NBH [list \x83 "${ob8}NB$cb8"]\ - IND [list \x84 "${ob8}IN$cb8"]\ - NEL [list \x85 "${ob8}NE$cb8"]\ - SSA [list \x86 "${ob8}SS$cb8"]\ - ESA [list \x87 "${ob8}ES$cb8"]\ - HTS [list \x88 "${ob8}HS$cb8"]\ - HTJ [list \x89 "${ob8}HT$cb8"]\ - VTS [list \x8a "${ob8}VT$cb8"]\ - PLD [list \x8b "${ob8}PD$cb8"]\ - PLU [list \x8c "${ob8}PU$cb8"]\ - RI [list \x8d "${ob8}RI$cb8"]\ - SS2 [list \x8e "${ob8}S2$cb8"]\ - SS3 [list \x8f "${ob8}S3$cb8"]\ - DCS [list \x90 "${ob8}DC$cb8"]\ - PU1 [list \x91 "${ob8}P1$cb8"]\ - PU2 [list \x92 "${ob8}P2$cb8"]\ - STS [list \x93 "${ob8}SX$cb8"]\ - CCH [list \x94 "${ob8}CC$cb8"]\ - MW [list \x95 "${ob8}MW$cb8"]\ - SPA [list \x96 "${ob8}SP$cb8"]\ - EPA [list \x97 "${ob8}EP$cb8"]\ - SOS [list \x98 "${ob8}SO$cb8"]\ - SCI [list \x9a "${ob8}SC$cb8"]\ - CSI [list \x9b "${ob8}CS$cb8"]\ - ST [list \x9c "${ob8}ST$cb8"]\ - OSC [list \x9d "${ob8}OS$cb8"]\ - PM [list \x9e "${ob8}PM$cb8"]\ - APC [list \x9f "${ob8}AP$cb8"]\ - ] - - #unicode Tags block - nonprinting mapped to ascii 0-127 - set visuals_tags [tcl::dict::create] - for {set i 917504} {$i < 917632} {incr i} { - set asciidec [expr {$i - 917504}] - set vis [format %c $asciidec] - if {[dict exists $map_c0 $vis]} { - set vis [dict get $map_c0 $vis] - } - tcl::dict::set visuals_tags TAG$asciidec [list [format %c $i] "${obt}$vis${cbt}"] - } - - - set hack [tcl::dict::create] - tcl::dict::set hack BOM1 [list \uFEFF "${obm}\U1f4a3$cbm"] ;#byte order mark/ ZWNBSP (ZWNBSP usage generally deprecated) - a picture of a bomb(2wide glyph) - tcl::dict::set hack ZWSP [list \u200B "${obm}ZWSP$cbm"] - #review - other boms? Encoding dependent? - - tcl::dict::set hack DCS [list \x90 "${ob8}\u2328 $cb8"] ;#keyboard from Miscellaneous Technical - 1 wide + pad. - tcl::dict::set hack SOS [list \x98 "${ob8}\u2380 $cb8"] ;#Insertion Symbol from Miscellaneous Technical - 1 wide + pad - tcl::dict::set hack ST [list \x9c "${ob8}\u2383 $cb8"] ;#Emphasis Symbol from Miscellaneous Technical - 1 wide + pad (graphically related to \u2380) - tcl::dict::set hack CSI [list \x9b "${ob8}\u2386 $cb8"] ;#Enter Symbol from Miscellaneous Technical - 1 wide + pad - tcl::dict::set hack OSC [list \x9d "${ob8}\u2b55$cb8"] ;#bright red ring from Miscellaneous Symbols and Arrows - 2 wide (OSC could be used for clipboard or other potentially security sensitive functions) - tcl::dict::set hack PM [list \x9e "${ob8}PM$cb8"] - tcl::dict::set hack APC [list \x9f "${ob8}\U1f534$cb8"] ;#bright red ball from Miscellaneoust Symbols and Pictographs - 2 wide (APC also noted as a potential security risk) - - set debug_visuals [tcl::dict::merge $visuals_c0 $visuals_c1 $hack $visuals_tags] - - #for repeated interaction with the same ANSI string - a mechanism to store state is more efficient - proc NEW {string} { - punk::ansi::class::class_ansistring new $string - } - proc VIEW {args} { - #*** !doctools - #[call [fun VIEW] [arg string]] - #[para]Return a string with specific ANSI control characters substituted with visual equivalents frome the appropriate unicode C0 and C1 visualisation sets - #[para]For debugging purposes, certain other standard control characters are converted to visual representation, for example backspace (mapped to \\U2408 '\U2408') - #[para]Horizontal tab is mapped to \\U2409 '\U2409'. For many of the punk terminal text operations, tabs have already been mapped to the appropriate number of spaces using textutil::tabify functions - #[para]As punkshell uses linefeed where possible in preference to crlf even on windows, cr is mapped to \\U240D '\U240D' - but lf is left as is. - - variable debug_visuals - - if {![llength $args]} { - return "" - } - - set string [lindex $args end] - set defaults [tcl::dict::create\ - -esc 1\ - -cr 1\ - -lf 0\ - -vt 0\ - -ff 1\ - -ht 1\ - -bs 1\ - -sp 1\ - ] - set argopts [lrange $args 0 end-1] - if {[llength $argopts] % 2} { - error "ansistring VIEW options must be option-value pairs, received '$argopts'. Known opts [tcl::dict::keys $defaults]" - } - set opts [tcl::dict::merge $defaults $argopts] - # -- --- --- --- --- - set opt_esc [tcl::dict::get $opts -esc] - set opt_cr [tcl::dict::get $opts -cr] - set opt_lf [tcl::dict::get $opts -lf] - set opt_vt [tcl::dict::get $opts -vt] - set opt_ff [tcl::dict::get $opts -ff] - set opt_ht [tcl::dict::get $opts -ht] - set opt_bs [tcl::dict::get $opts -bs] - set opt_sp [tcl::dict::get $opts -sp] - # -- --- --- --- --- - - # -lf 2, -vt 2 and -ff 2 are useful for CRM mode (Show Control Character Mode) in the terminal - where a newline is expected to display after the character. - - - set visuals_opt $debug_visuals - set visuals_opt [dict remove $visuals_opt CR ESC LF VT FF HT BS SP] - - if {$opt_esc} { - tcl::dict::set visuals_opt ESC [list \x1b \u241b] - } else { - tcl::dict::unset visuals_opt ESC - } - if {$opt_cr} { - tcl::dict::set visuals_opt CR [list \x0d \u240d] - } - if {$opt_lf == 1} { - tcl::dict::set visuals_opt LF [list \x0a \u240a] - } - if {$opt_lf == 2} { - tcl::dict::set visuals_opt LF [list \x0a \u240a\n] - } - if {$opt_vt == 1} { - tcl::dict::set visuals_opt VT [list \x0b \u240b] - } - if {$opt_vt == 2} { - tcl::dict::set visuals_opt VT [list \x0b \u240b\n] - } - switch -exact -- $opt_ff { - 1 { - tcl::dict::set visuals_opt FF [list \x0c \u240c] - } - 2 { - tcl::dict::set visuals_opt FF [list \x0c \u240c\n] - } - } - if {$opt_ht} { - tcl::dict::set visuals_opt HT [list \x09 \u2409] - } - if {$opt_bs} { - tcl::dict::set visuals_opt BS [list \x08 \u2408] - } - if {$opt_sp} { - tcl::dict::set visuals_opt SP [list \x20 \u2420] - } - - #set visuals [tcl::dict::merge $visuals_opt $debug_visuals] - #set charmap [list] - #tcl::dict::for {nm chars} $visuals_opt { - # lappend charmap {*}$chars - #} - #return [tcl::string::map $charmap $string] - return [tcl::string::map [concat {*}[dict values $visuals_opt]] $string] - - - #test of ISO2047 - 7bit - limited set, limited support, somewhat obscure glyphs - #return [tcl::string::map [list \033 \U2296 \007 \U237E] $string] - } - - #The implementation of viewcodes,viewstyle is more efficiently done in an object for the case where repeated calls of various methods can re-use the internal splits. - #for oneshots here - there is only minor overhead to use and destroy the object here. - proc VIEWCODES {args} { - set string [lindex $args end] - if {$string eq ""} { - return "" - } - set arglist [lrange $args 0 end-1] - set ansistr [ansistring NEW $string] - set result [$ansistr viewcodes {*}$arglist] - $ansistr destroy - return $result - } - #an attempt to show the codes and colour/style of the *input* - #ie we aren't looking at the row/column positioning - but we do want to keep track of cursor attribute saves and restores - proc VIEWSTYLE {args} { - set string [lindex $args end] - if {$string eq ""} { - return "" - } - set arglist [lrange $args 0 end-1] - set ansistr [ansistring NEW $string] - set result [$ansistr viewstyle {*}$arglist] - $ansistr destroy - return $result - } - - - #todo - change to COUNT to emphasize the difference between this and doing a Tcl string length on the ansistriped string! - #review. Tabs/elastic tabstops. Do we want to count a tab as one element? Probably so if we are doing so for \n etc and not counting 2W unicode. - #Consider leaving tab manipualation for a width function which determines columns occupied for all such things. - proc COUNT {string} { - #*** !doctools - #[call [fun COUNT] [arg string]] - #[para]Returns the count of visible graphemes and non-ansi control characters - #[para]Incomplete! grapheme clustering support not yet implemented - only diacritics are currently clustered to count as one grapheme. - #[para]This will not count strings hidden inside a 'privacy message' or other ansi codes which may have content between their opening escape and their termination sequence. - #[para]This is not quite equivalent to calling string length on the result of ansistrip $string due to diacritics and/or grapheme combinations - #[para]Note that this returns the number of characters in the payload (after applying combiners) - #It is not always the same as the width of the string as rendered on a terminal due to 2wide Unicode characters and the usual invisible control characters such as \r and \n - #[para]To get the width, use punk::ansi::printing_length instead, which is also ansi aware. - - #stripping diacritics only makes sense if we are counting them as combiners and also treating unicode grapheme combinations as single entities. - #as Our ansistring INDEX function returns the character with diacritics, and will ultimately return grapheme clusters as a single element - we strip theme here as not counted. - #todo - combiners/diacritics? just map them away here? - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} - set string [regsub -all $re_diacritics $string ""] - - #we want length to return number of glyphs.. not screen width. Has to be consistent with index function - tcl::string::length [ansistrip $string] - } - #included as a test/verification - slightly slower. - #grapheme split version may end up being used once it supports unicode grapheme clusters - proc count2 {string} { - #we want count to return number of glyphs.. not screen width. Has to be consistent with index function - return [llength [punk::char::grapheme_split [ansistrip $string]]] - } - - proc length {string} { - tcl::string::length [ansistrip $string] - } - - proc _splits_trimleft {sclist} { - set intext 0 - set outlist [list] - foreach {pt ansiblock} $sclist { - if {$ansiblock ne ""} { - if {!$intext} { - if {$pt eq "" || [regexp {^\s+$} $pt]} { - lappend outlist "" $ansiblock - } else { - lappend outlist [tcl::string::trimleft $pt] $ansiblock - set intext 1 - } - } else { - lappend outlist $pt $ansiblock - } - } else { - if {!$intext} { - if {$pt eq "" || [regexp {^\s+$} $pt]} { - lappend outlist "" - } else { - lappend outlist [tcl::string::trimleft $pt] - set intext 1 - } - } else { - lappend outlist $pt - } - } - } - return $outlist - } - proc _splits_trimright {sclist} { - set intext 0 - set outlist [list] - #we need to account for empty ansiblock var caused by dual-var iteration over odd length list - foreach {pt ansiblock} [lreverse $sclist] { - if {$ansiblock ne ""} { - if {!$intext} { - if {$pt eq "" || [regexp {^\s+$} $pt]} { - lappend outlist "" $ansiblock - } else { - lappend outlist [tcl::string::trimright $pt] $ansiblock - set intext 1 - } - } else { - lappend outlist $pt $ansiblock - } - } else { - if {!$intext} { - if {$pt eq "" || [regexp {^\s+$} $pt]} { - lappend outlist "" - } else { - lappend outlist [tcl::string::trimright $pt] - set intext 1 - } - } else { - lappend outlist $pt - } - } - } - return [lreverse $outlist] - } - - proc _splits_trim {sclist} { - return [_splits_trimright [_splits_trimleft $sclist]] - } - - #Note that trim/trimleft/trimright will trim spaces at the extremities that are styled with background colour, underline etc - #that may be unexpected, but it's probably the only thing that makes sense. Plain string trim can chop off whitespace that is extraneous to the ansi entirely. - proc trimleft {string args} { - set intext 0 - set out "" - #for split_codes only first or last pt can be empty string - but we can also get an empty ansiblock by using foreach with 2 vars on an odd-length list - foreach {pt ansiblock} [split_codes $string] { - if {!$intext} { - if {$pt eq "" || [regexp {^\s+$} $pt]} { - append out $ansiblock - } else { - append out [tcl::string::trimleft $pt]$ansiblock - set intext 1 - } - } else { - append out $pt$ansiblock - } - } - return $out - } - proc trimright {string} { - if {$string eq ""} {return ""} ;#excludes the case where split_codes would return nothing - set rtrimmed_list [_splits_trimright [split_codes $string]] - return [join $rtrimmed_list ""] - } - proc trim {string} { - #make sure we do our ansi-scanning split only once - so use list-based trim operations - #order of left vs right probably makes zero difference - as any reduction the first operation can do is only in terms of characters at other end of list - not in total list length - #we save a single function call by calling both here rather than _splits_trim - join [_splits_trimright [_splits_trimleft [split_codes $string]]] "" - } - - #Capitalised because it's the clustered grapheme/controlchar index - not the tcl string index - proc INDEX {string index} { - #*** !doctools - #[call [fun index] [arg string] [arg index]] - #[para]Takes a string that possibly contains ansi codes such as colour,underline etc (SGR codes) - #[para]Returns the character (with applied ansi effect) at position index - #[para]The string could contain non SGR ansi codes - and these will (mostly) be ignored, so shouldn't affect the output. - #[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST) - #[para]It's arguable some of these are application specific - but this function takes the view that they are probably non-displaying - so index won't see them. - #[para]If the caller wants just the character - they should use a normal string index after calling ansistrap, or call ansistrip afterwards. - #[para]As any operation using end-+ will need to strip ansi to precalculate the length anyway; the caller should probably just use ansistrip and standard string index if the ansi coded output isn't required and they are using and end-based index. - #[para]In fact, any operation where the ansi info isn't required in the output would probably be slightly more efficiently obtained by using ansistrip and normal string operations on that. - #[para]The returned character will (possibly) have a leading ansi escape sequence but no trailing escape sequence - even if the string was taken from a position immediately before a reset or other SGR ansi code - #[para]The ansi-code prefix in the returned string is built up by concatenating previous SGR ansi codes seen - but it is optimised to re-start the process if any full SGR reset is encountered. - #[para]The code sequence doesn't detect individual properties being turned on and then off again, only full resets; so in some cases the ansi-prefix may not be as short as it could be. - #[para]This shouldn't make any difference to the visual output - but a possible future enhancement is something to produce the shortest ansi sequence possible - #[para]Notes: - #[para]This function has to split the whole string into plaintext & ansi codes even for a very low index - #[para]Some sort of generator that parses more of the string as required might be more efficient for large chunks. - #[para]For end-x operations we have to pre-calculate the content-length by stripping the ansi - which is also potentially sub-optimal - - set ansisplits [split_codes_single $string]; #we get empty pt(plaintext) between each ansi code that is in a run - - #todo - end-x +/-x+/-x etc - set original_index $index - - set index [tcl::string::map [list _ ""] $index] - #short-circuit some trivial cases - if {[tcl::string::is integer -strict $index]} { - if {$index < 0} {return ""} - #this only short-circuits an index greater than length including ansi-chars - #we don't want to spend cycles stripping ansi for this test so code below will still have to handle index just larger than content-length but still less than entire length - if {$index > [tcl::string::length $string]} {return ""} - } else { - if {[tcl::string::match end* $index]} { - #for end- we will probably have to blow a few cycles stripping first and calculate the length - if {$index ne "end"} { - set op [tcl::string::index $index 3] - set offset [tcl::string::range $index 4 end] - if {$op ni {+ -} || ![tcl::string::is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} - if {$op eq "+" && $offset != 0} { - return "" - } - } else { - set offset 0 - } - #by now, if op = + then offset = 0 so we only need to handle the minus case - set payload_len [punk::ansi::ansistring::length $string] ;#a little bit wasteful - but hopefully no big deal - if {$offset == 0} { - set index [expr {$payload_len-1}] - } else { - set index [expr {($payload_len-1) - $offset}] - } - if {$index < 0} { - #don't waste time splitting and looping the string - return "" - } - } else { - #we are trying to avoid evaluating unbraced expr of potentially insecure origin - regexp {^([+-]{0,1})(.*)} $index _match sign tail ;#should always match - even empty string - if {[tcl::string::is integer -strict $tail]} { - #plain +- - if {$op eq "-"} { - #return nothing for negative indices as per Tcl's lindex etc - return "" - } - set index $tail - } else { - if {[regexp {(.*)([+-])(.*)} $index _match a op b]} { - if {[tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} { - if {$op eq "-"} { - set index [expr {$a - $b}] - } else { - set index [expr {$a + $b}] - } - } else { - error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" - } - } else { - error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" - } - } - } - } - - #any pt could be empty if using split_codes_single (or just first and last pt if split_codes) - set low -1 - set high -1 - set pt_index -2 - set pt_found -1 - set char "" - #set grapheme_codestacks [list] ;#stack of codes per grapheme - will be flattened/coalesced - set codestack [list] - #we can't only apply leading sequence from previous code - as there may be codes in effect from earlier, so we have to track as we go - #(this would apply even if we used split_codes - but then we would need to do further splitting of each codeset anyway) - foreach {pt code} $ansisplits { - incr pt_index 2 - #we want an index per grapheme - whether it is doublewide or single - - if {$pt ne ""} { - set graphemes [punk::char::grapheme_split $pt] - set low [expr {$high + 1}] ;#last high - #incr high [tcl::string::length $pt] - incr high [llength $graphemes] - } - - if {$pt ne "" && ($index >= $low && $index <= $high)} { - set pt_found $pt_index - #set char [tcl::string::index $pt $index-$low] - set char [lindex $graphemes $index-$low] - break - } - - if {[punk::ansi::codetype::is_sgr_reset $code]} { - #we can throw away previous codestack - set codestack [list] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } else { - #may have partial resets - #sgr_merge_list will handle at end - #we don't apply non SGR codes to our output. This is probably what is wanted - but should be reviewed. - #Review - consider if any other types of code make sense to retain in the output in this context. - if {[punk::ansi::codetype::is_sgr $code]} { - lappend codestack $code - } - } - - } - if {$pt_found >= 0} { - return [punk::ansi::codetype::sgr_merge_list {*}$codestack]$char - } else { - return "" - } - } - - #helper to convert indices (possibly of form x+y end-x etc) to numeric values within the payload range i.e without ansi - #return empty string for each index that is out of range - #review - this is possibly too slow to be very useful as is. - # consider converting to oo and maintaining state of ansisplits so we don't repeat relatively expensive operations for same string - #see also punk::lindex_resolve / punk::lindex_get for ways to handle tcl list/string indices without parsing them. - proc INDEXABSOLUTE {string args} { - set payload_len -1 ;# -1 as token to indicate we haven't calculated it yet (only want to call it once at most) - set testindices [list] - foreach index $args { - if {[tcl::string::is integer -strict $index]} { - if {$index < 0} { - lappend testindices "" - } elseif {$index > [tcl::string::length $string]} { - #this only short-circuits an index greater than length including ansi-chars - #we don't want to spend cycles stripping ansi for this test so code below will still have to handle index just larger than content-length but still less than entire length - lappend testindices "" - } else { - lappend testindices $index - } - } else { - if {[tcl::string::match end* $index]} { - #for end- we will probably have to blow a few cycles stripping first and calculate the length - if {$index ne "end"} { - set op [tcl::string::index $index 3] - set offset [tcl::string::range $index 4 end] - if {$op ni {+ -} || ![tcl::string::is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} - if {$op eq "+" && $offset != 0} { - lappend testindices "" - continue - } - } else { - set offset 0 - } - #by now, if op = + then offset = 0 so we only need to handle the minus case - if {$payload_len == -1} { - set payload_len [punk::ansi::ansistring::length $string] ;#a little bit wasteful - but hopefully no big deal - } - if {$offset == 0} { - set index [expr {$payload_len-1}] - } else { - set index [expr {($payload_len-1) - $offset}] - } - if {$index < 0} { - lappend testindices "" - } else { - lappend testindices $index - } - } else { - #we are trying to avoid evaluating unbraced expr of potentially insecure origin - regexp {^([+-]{0,1})(.*)} $index _match sign tail ;#should always match - even empty string - if {[tcl::string::is integer -strict $tail]} { - #plain +- - if {$op eq "-"} { - #return nothing for negative indices as per Tcl's lindex etc - lappend indices "" - continue - } - set index $tail - lappend testindices $index - } else { - if {[regexp {(.*)([+-])(.*)} $index _match a op b]} { - if {[tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} { - if {$op eq "-"} { - set index [expr {$a - $b}] - } else { - set index [expr {$a + $b}] - } - } else { - error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" - } - } else { - error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" - } - lappend testindices $index - } - } - } - #assertion - we made exactly one append to testindices if there was no error - } - #we now have numeric or empty string indices - but haven't fully checked they are within the underlying payload length - - if {[join $testindices ""] eq ""} { - #don't calc ansistring length if no indices to check - return $testindices - } - if {$payload_len == -1} { - set payload_len [punk::ansi::ansistring::length $string] - } - set indices [list] - foreach ti $testindices { - if {$ti ne ""} { - if {$ti < $payload_len} { - lappend indices $ti - } else { - lappend indices "" - } - } else { - lappend indices "" - } - } - return $indices - - } - - #Todo - rows! Note that a 'row' doesn't represent an output row if the ANSI string we are working with contains movement/cursor restores etc. - #The column/row concept works for an ansistring that has been 'rendered' to some defined area. - #row for arbitrary ANSI input only tells us which line of input we are in - e.g a single massive line of ANSI input would appear to have one row but could result in many rendered output rows. - - #return pair of column extents occupied by the character index supplied. - #single-width grapheme will return pair of integers of equal value - #double-width grapheme will return a pair of consecutive indices - proc INDEXCOLUMNS {string idx} { - #There is an index per grapheme - whether it is 1 or 2 columns wide - set index [lindex [INDEXABSOLUTE $string $idx] 0] - if {$index eq ""} { - return "" - } - set ansisplits [split_codes_single $string]; #we get empty pt(plaintext) between each ansi code that is in a run - set low -1 ;#low and high grapheme indexes - set high -1 - set lowc 0 ;#low and high column (1 based) - set highc 0 - set col1 "" - set col2 "" - set row 1 - foreach {pt code} $ansisplits { - if {$pt ne ""} { - set ptlines [split $pt \n] - set ptlinecount [llength $ptlines] - set ptlineindex 0 - foreach ptline $ptlines { - set graphemes [punk::char::grapheme_split $ptline] - if {$ptlineindex > 0} { - #todo - account for previous \n as a grapheme .. what column? It should theoretically be in the rightmost column - #zero width - set low [expr {$high + 1}] - set lowc [expr {$highc + 1}] - set high $low - set highc $lowc - if {$index == $low} { - set char \n - set col1 $lowc - set col2 $col1 - break - } - incr row - set lowc 0 - set highc 0 - } - set low [expr {$high + 1}] ;#last high - set lowc [expr {$highc + 1}] - set high [expr {$low + [llength $graphemes] -1}] - set highc [expr {$lowc + [punk::char::ansifreestring_width $ptline] -1}] - #puts "---row:$row lowc:$lowc highc:$highc $ptline graphemes:$graphemes" - if {$index >= $low && $index <= $high} { - set char [lindex $graphemes $index-$low] - set prefix [join [lrange $graphemes 0 [expr {$index-$low-1}]] ""] - set prefixlen [punk::char::ansifreestring_width $prefix] - set col1 [expr {$lowc + $prefixlen}] - set gwidth [punk::char::ansifreestring_width $char] - if {$gwidth < 1} { - puts stderr "ansistring INDEXCOLUMNS warning - grapheme width zero at column $col1 ??" - return "" ;#grapheme doesn't occupy a column and isn't a newline? - review - } - set col2 [expr {$col1 + ($gwidth -1)}] - break - } - incr ptlineindex - } - } - } - if {$col1 ne "" & $col2 ne ""} { - return [list $col1 $col2] - } - } - - #multiple rows - return a list? - #return the grapheme index that occupies column col (could be first or second half of 2-wide grapheme) - proc COLUMNINDEX {string col} { - - set ansisplits [split_codes_single $string]; #we get empty pt(plaintext) between each ansi code that is in a run - set lowindex -1 ;#low and high grapheme indexes - set highindex -1 - set lowc 0 ;#low and high column (1 based) - set highc 0 - set col1 "" - set col2 "" - foreach {pt code} $ansisplits { - if {$pt ne ""} { - if {[tcl::string::last \n $pt] < 0} { - set graphemes [punk::char::grapheme_split $pt] - set lowindex [expr {$highindex + 1}] ;#last high - set lowc [expr {$highc + 1}] - set highindex [expr {$lowindex + [llength $graphemes] -1}] - set highc [expr {$lowc + [punk::char::ansifreestring_width $pt] -1}] - if {$col >= $lowc && $col <= $highc} { - if {$col == $lowc} { - return $lowindex - } elseif {$col == $highc} { - return $highindex - } - set index [expr {$lowindex -1}] - set str "" - foreach g $graphemes { - incr index - append str $g - set width [punk::char::ansifreestring_width $str] - if {$lowc-1 + $width >= $col} { - return $index - } - } - error "ansistring COLUMNINDEX '$string' $col not found" ;#assertion - shouldn't happen - } - } else { - error "ansistring COLUMNINDEX multiline not implemented" - } - } - } - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}] -} - - -tcl::namespace::eval punk::ansi::control { - proc APC {args} { - return \x1b_[join $args {;}]\x1b\\ - } - proc APC8 {args} { - return \x9f[join $args {;}]\x9c - } - proc CSI {args} { - set finalarg [lindex $args end] - set finalbyte [string index $finalarg end] - if {![regexp {[\x40-\x73]} $finalbyte]} { - error "::punk::ansi::control::CSI final byte must be one in the set @A-Z\[\\\]^_`a-z\{|\}~" - } - if {$finalarg eq $finalbyte} { - return \x1b\[[join [lrange $args 0 end-1] {;}]$finalbyte - } else { - return \x1b\[[join $args {;}] - } - } - proc CSI8 {args} { - set finalarg [lindex $args end] - set finalbyte [string index $finalarg end] - if {![regexp {[\x40-\x73]} $finalbyte]} { - error "::punk::ansi::control::CSI final byte must be one in the set @A-Z\[\\\]^_`a-z\{|\}~" - } - if {$finalarg eq $finalbyte} { - return \x9b[join [lrange $args 0 end-1] {;}]$finalbyte - } else { - return \x9b[join $args {;}] - } - } - proc DCS {args} { - return \x1bP[join $args {;}]\x1b\\ - } - proc DCS8 {args} { - return \x90[join $args {;}]\x9c - } - proc OSC {args} { - return \x1b\][join $args {;}]\x1b\\ - } - proc OSC8 {args} { - return \x9d[join $args {;}]\x9c - } -} - -namespace eval punk::ansi::colour { - package require punk::assertion - if {[catch {namespace import ::punk::assertion::assert} errM]} { - puts stderr "punk error importing punk::assertion::assert\n$errM" - puts stderr "punk::a* commands:[info commands ::punk::a*]" - } - punk::assertion::active on - - - #see also the tk function - #winfo rgb . |#XXXXXX|#XXX - #(example in punk::ansi::colourmap::get_rgb_using_tk) - - #proc percent2rgb {n} { - # # map 0..100 to a red-yellow-green sequence - # set n [expr {$n < 0? 0: $n > 100? 100: $n}] - # set red [expr {$n > 75? 60 - ($n * 15 / 25) : 15}] - # set green [expr {$n < 50? $n * 15 / 50 : 15}] - # format "#%01x%01x0" $red $green - #} ;#courtesy of RS (from tcl wiki) - proc percent2#rgb {n} { - # map 0..100 to a red-yellow-green sequence - set n [expr {$n < 0? 0: $n > 100? 100: $n}] - set red [expr {$n > 75? 1020 - ($n * 255 / 25) : 255}] - set green [expr {$n < 50? $n * 255 / 50 : 255}] - format "#%02x%02x00" $red $green - } - - proc random#rgb {} { - format #%06x [expr {int(rand() * 0xFFFFFF)}] - } - - - #see also colors package - #https://sourceforge.net/p/irrational-numbers/code/HEAD/tree/pkgs/Colors/trunk/colors.tcl#l159 - - - # classic formula for luminance (0.0 .. 100.0) - proc luminance {R G B} { - return [expr {(0.3*$R + 0.59*$G + 0.11*$B)/255.0}] - } - #New colour's luminance is dark if orig-colour is bright, and viceversa - #(note not all colours are invertable to return original) - proc contrasting {R G B} { - set lum [luminance $R $G $B] - if {$lum < 0.597} { - set lum 0.9 - } else { - set lum 0.2 - } - lassign [RGB2hsl $R $G $B] h s l - return [hsl2RGB $h $s $lum] - } - proc contrast_pair {R G B} { - set contra [contrasting $R $G $B] - set back [contrasting {*}$contra] - return [list $back $contra] ;#back may or may not equal original R G B - } - - - proc hsl2RGB { H S L } { - if { $L < 0.5 } { - set Q [expr {$L*(1.0+$S)}] - } else { - set Q [expr {$L+$S-($L*$S)}] - } - set P [expr {2.0*$L-$Q}] - set Hk [expr {$H/360.0}] - set T(R) [expr {$Hk+1.0/3.0}] - set T(G) $Hk - set T(B) [expr {$Hk-1.0/3.0}] - - # normalize - foreach c {R G B} { - if {$T($c) < 0.0} { set T($c) [expr {$T($c)+1.0}] } - if {$T($c) > 1.0} { set T($c) [expr {$T($c)-1.0}] } - } - - foreach c {R G B} { - if {$T($c) < (1.0/6.0)} { - set T($c) [expr {$P+($Q-$P)*6.0*$T($c)}] - } elseif {$T($c) < 0.5} { - set T($c) $Q - } elseif {$T($c) < (2.0/3.0)} { - set T($c) [expr {$P+($Q-$P)*(2.0/3.0-$T($c))*6.0}] - } else { - set T($c) $P - } - set T($c) [expr {round($T($c)*255)}] - } - - return [list $T(R) $T(G) $T(B)] - } - proc RGB2hsl { R G B } { - set r [expr {$R/255.0}] - set g [expr {$G/255.0}] - set b [expr {$B/255.0}] - - set max $r - set min $r - if { $g > $max } { set max $g } - if { $g < $min } { set min $g } - if { $b > $max } { set max $b } - if { $b < $min } { set min $b } - - if { $max == $min } { - set H 0.0 - } elseif { $b == $max } { - set H [expr {60* ($r-$g)/($max-$min)+240}] - } elseif { $g == $max } { - set H [expr {60* ($b-$r)/($max-$min)+120}] - } else { - # $r == $max - if { $g >= $b } { - set H [expr {60* ($g-$b)/($max-$min)}] - } else { - set H [expr {60* ($g-$b)/($max-$min)+360}] - } - } - - set L [expr {($max+$min)/2}] - - if { $L == 0.0 || $max == $min } { - set S 0.0 - } elseif { $L <= 0.5 } { - set S [expr {($max-$min)/($max+$min)}] - } else { - set S [expr {($max-$min)/(2.0-($max+$min))}] - } - - return [list $H $S $L] - } - - - #red green blue to hsl (hue saturation luminance) - #https://www.rapidtables.com/convert/color/rgb-to-hsl.html - proc jexer_rgb_to_hsl {red green blue} { - #algorithm port from Jexer LegacySixelEncode.java - with thanks to Autumn Lamonte (MIT lic) - assert {$red >=0 && $red <= 255} - assert {$green >=0 && $green <= 255} - assert {$blue >=0 && $blue <= 255} - set R [expr {$red / 255.0}] - set G [expr {$green / 255.0}] - set B [expr {$blue / 255.0}] - set Rmax 0 - set Gmax 0 - set Bmax 0 - set min [expr {$R < $G ? $R : $G}] - set min [expr {$min < $B ? $min : $B}] - set max 0 - if {($R >= $G) && ($R >= $B)} { - set max $R - set Rmax 1 - } elseif {($G >= $R) && ($G >= $B)} { - set max $G - set Gmax 1 - } elseif {($B >= $G) && ($B >= $R)} { - set max $B - set Bmax 1 - } - set L [expr {($min + $max) / 2.0}] - set H 0.0 - set S 0.0 - #REVIEW - java allows floating point division by 0.0 - producing positive infinity, negative infinity or NaN - #This makes the original java algorithm a little more obscure - if {$min != $max} { - #no divide by zero issues due to min != max - if {$L < 0.5} { - set S [expr {($max - $min) / ($max + $min)}] - } else { - set S [expr {($max - $min) / (2.0 - $max - $min)}] - } - } - if {$Rmax} { - #puts "G'$G' B'$B' max'$max' min'$min'" - assert {$Gmax == 0} - assert {$Bmax == 0} - if {($max - $min) == 0} { - set H 0.0 ;#review - } else { - set H [expr {($G - $B) / ($max - $min)}] - } - } elseif {$Gmax} { - assert {$Rmax == 0} - assert {$Bmax == 0} - if {($max - $min) == 0} { - set H 2.0 - } else { - set H [expr {2.0 + ($B - $R) / ($max - $min)}] - } - } elseif {$Bmax} { - assert {$Rmax == 0} - assert {$Gmax == 0} - if {($max - $min) == 0} { - set H 4.0 - } else { - set H [expr {4.0 + ($R - $G) / ($max - $min)}] - } - } - if {$H < 0.0} { - set H [expr {$H + 6.0}] - } - - #Tcl mathfunc round vs int (which rounds down) - set hue [expr {round($H * 60)}] - set sat [expr {round($S * 100)}] - set lum [expr {round($L * 100)}] - assert {$hue >= 0 && $hue <= 360} - assert {$sat >= 0 && $sat <= 100} - assert {$lum >= 0 && $lum <= 100} - - return [list $hue $sat $lum] - } -} -tcl::namespace::eval punk::ansi::internal { - proc splitn {str {len 1}} { - #from textutil::split::splitn - if {$len <= 0} { - return -code error "len must be > 0" - } - if {$len == 1} { - return [split $str {}] - } - set result [list] - set max [tcl::string::length $str] - set i 0 - set j [expr {$len -1}] - while {$i < $max} { - lappend result [tcl::string::range $str $i $j] - incr i $len - incr j $len - } - return $result - } - proc splitx {str {regexp {[\t \r\n]+}}} { - #from textutil::split::splitx - # Bugfix 476988 - if {$str eq ""} { - return {} - } - if {$regexp eq ""} { - return [::split $str ""] - } - if {[regexp $regexp {}]} { - return -code error \ - "splitting on regexp \"$regexp\" would cause infinite loop" - } - set list {} - set start 0 - while {[regexp -start $start -indices -- $regexp $str match submatch]} { - #foreach {subStart subEnd} $submatch break - lassign $submatch subStart subEnd - #foreach {matchStart matchEnd} $match break - lassign $match matchStart matchEnd - incr matchStart -1 - incr matchEnd - lappend list [tcl::string::range $str $start $matchStart] - if {$subStart >= $start} { - lappend list [tcl::string::range $str $subStart $subEnd] - } - set start $matchEnd - } - lappend list [tcl::string::range $str $start end] - return $list - } - - proc printing_length_addchar {i c} { - upvar outchars outc - upvar outsizes outs - set nxt [llength $outc] - if {$i < $nxt} { - lset outc $i $c - } else { - lappend outc $c - } - } - - #string to 2digit hex - e.g used by XTGETTCAP - proc str2hex {input} { - set 2hex "" - foreach ch [split $input ""] { - append 2hex [format %02X [scan $ch %c]] - } - return $2hex - } - proc hex2str {2digithexchars} { - set 2digithexchars [tcl::string::map [list _ ""] $2digithexchars] ;#compatibility with tcl tip 551 (compatibility in the sense that users might expect to be able to use underscores and it's nice to support the syntax here too - not that it's required) - if {$2digithexchars eq ""} { - return "" - } - if {[tcl::string::length $2digithexchars] % 2} { - error "hex2str requires an even number of hex digits (2 per character)" - } - set 2str "" - foreach pair [splitn $2digithexchars 2] { - append 2str [format %c 0x$pair] - } - return $2str - } -} - -tcl::namespace::eval punk::ansi { - namespace import ::punk::ansi::ta::detect -} - -#inserting into global namespace like this should be kept to a minimum.. but this is considered a core aspect of punk::ansi -#todo - document -interp alias {} ansistring {} ::punk::ansi::ansistring - -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::ansi ::punk::ansi::class ::punk::ansi::ta -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::ansi [tcl::namespace::eval punk::ansi { - variable version - set version 0.1.1 -}] -return - - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm deleted file mode 100644 index 6e8e28e4..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm +++ /dev/null @@ -1,966 +0,0 @@ -# -*- 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 ::punk::ansi::colourmap 0.1.0 -# Meta platform tcl -# Meta license MIT -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin shellspy_module_::punk::ansi::colourmap 0 0.1.0] -#[copyright "2025"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require ::punk::ansi::colourmap] -#[keywords module] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of ::punk::ansi::colourmap -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by ::punk::ansi::colourmap -#[list_begin itemized] - -package require Tcl 8.6- -#*** !doctools -#[item] [package {Tcl 8.6}] - - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - - -tcl::namespace::eval ::punk::ansi::colourmap { - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - # Base namespace - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - #*** !doctools - #[subsection {Namespace ::punk::ansi::colourmap}] - #[para] Core API functions for ::punk::ansi::colourmap - #[list_begin definitions] - - variable PUNKARGS - - #---------------------------------------------- - #todo - document vars as part of package API - #- or provide a function to return varnames? - #- or wrap each in a function and see if any performance/memory impact? (readonly - so should just be a reference without any copying?) - #TK_colour_map - #TK_colour_map_lookup - #TK_colour_map_merge - #TK_colour_map_reverse - #---------------------------------------------- - - - - #significantly slower than tables - but here as a check/test - lappend PUNKARGS [list { - @id -id ::punk::ansi::colourmap::get_rgb_using_tk - @cmd -name punk::ansi::colourmap::get_rgb_using_tk -help\ - "This function requires Tk to function, and will call - 'package require tk' to load it. - The name argument accepts Tk colour names or hex values - in either #XXX or #XXXXXX format. - Tk colour names can be displayed using the command: - punk::ansi::a? tk ?glob..? - - get_rgb_using_tk returns a decimal rgb string delimited with dashes. - e.g - get_rgb_using_tk #FFF - 255-255-255 - get_rgb_using_tk SlateBlue - 106-90-205" - @leaders - name -type string|stringstartswith(#) - }] - proc get_rgb_using_tk {name} { - package require tk - #assuming 'winfo depth .' is always 32 ? - set RGB [winfo rgb . $name] - set rgb [lmap n $RGB {expr {$n / 256}}] - return [join $rgb -] - } - - variable TK_colour_map - tcl::dict::set TK_colour_map "alice blue" 240-248-255 - tcl::dict::set TK_colour_map AliceBlue 240-248-255 - tcl::dict::set TK_colour_map "antique white" 250-235-215 - tcl::dict::set TK_colour_map AntiqueWhite 250-235-215 - tcl::dict::set TK_colour_map AntiqueWhite1 255-239-219 - tcl::dict::set TK_colour_map AntiqueWhite2 238-223-204 - tcl::dict::set TK_colour_map AntiqueWhite3 205-192-176 - tcl::dict::set TK_colour_map AntiqueWhite4 139-131-120 - tcl::dict::set TK_colour_map aqua 0-255-255 - tcl::dict::set TK_colour_map aquamarine 127-255-212 - tcl::dict::set TK_colour_map aquamarine1 127-255-212 - tcl::dict::set TK_colour_map aquamarine2 118-238-198 - tcl::dict::set TK_colour_map aquamarine3 102-205-170 - tcl::dict::set TK_colour_map aquamarine4 69-139-16 - tcl::dict::set TK_colour_map azure 240-255-255 - tcl::dict::set TK_colour_map azure1 240-255-255 - tcl::dict::set TK_colour_map azure2 224-238-238 - tcl::dict::set TK_colour_map azure3 193-205-205 - tcl::dict::set TK_colour_map azure4 131-139-139 - tcl::dict::set TK_colour_map beige 245-245-220 - tcl::dict::set TK_colour_map bisque 255-228-196 - tcl::dict::set TK_colour_map bisque1 255-228-196 - tcl::dict::set TK_colour_map bisque2 238-213-183 - tcl::dict::set TK_colour_map bisque3 205-183-158 - tcl::dict::set TK_colour_map bisque4 139-125-107 - tcl::dict::set TK_colour_map black 0-0-0 - tcl::dict::set TK_colour_map "blanched almond" 255-235-205 - tcl::dict::set TK_colour_map BlanchedAlmond 255-235-205 - tcl::dict::set TK_colour_map blue 0-0-255 - tcl::dict::set TK_colour_map "blue violet" 138-43-226 - tcl::dict::set TK_colour_map blue1 0-0-255 - tcl::dict::set TK_colour_map blue2 0-0-238 - tcl::dict::set TK_colour_map blue3 0-0-205 - tcl::dict::set TK_colour_map blue4 0-0-139 - tcl::dict::set TK_colour_map BlueViolet 138-43-226 - tcl::dict::set TK_colour_map brown 165-42-42 - tcl::dict::set TK_colour_map brown1 255-64-64 - tcl::dict::set TK_colour_map brown2 238-59-59 - tcl::dict::set TK_colour_map brown3 205-51-51 - tcl::dict::set TK_colour_map brown4 139-35-35 - tcl::dict::set TK_colour_map burlywood 222-184-135 - tcl::dict::set TK_colour_map burlywood1 255-211-155 - tcl::dict::set TK_colour_map burlywood2 238-197-145 - tcl::dict::set TK_colour_map burlywood3 205-170-125 - tcl::dict::set TK_colour_map burlywood4 139-115-85 - tcl::dict::set TK_colour_map "cadet blue" 95-158-160 - tcl::dict::set TK_colour_map CadetBlue 95-158-160 - tcl::dict::set TK_colour_map CadetBlue1 152-245-255 - tcl::dict::set TK_colour_map CadetBlue2 142-229-238 - tcl::dict::set TK_colour_map CadetBlue3 122-197-205 - tcl::dict::set TK_colour_map CadetBlue4 83-134-139 - tcl::dict::set TK_colour_map chartreuse 127-255-0 - tcl::dict::set TK_colour_map chartreuse1 127-255-0 - tcl::dict::set TK_colour_map chartreuse2 118-238-0 - tcl::dict::set TK_colour_map chartreuse3 102-205-0 - tcl::dict::set TK_colour_map chartreuse4 69-139-0 - tcl::dict::set TK_colour_map chocolate 210-105-30 - tcl::dict::set TK_colour_map chocolate1 255-127-36 - tcl::dict::set TK_colour_map chocolate2 238-118-33 - tcl::dict::set TK_colour_map chocolate3 205-102-29 - tcl::dict::set TK_colour_map chocolate4 139-69-19 - tcl::dict::set TK_colour_map coral 255-127-80 - tcl::dict::set TK_colour_map coral1 255-114-86 - tcl::dict::set TK_colour_map coral2 238-106-80 - tcl::dict::set TK_colour_map coral3 205-91-69 - tcl::dict::set TK_colour_map coral4 139-62-47 - tcl::dict::set TK_colour_map "cornflower blue" 100-149-237 - tcl::dict::set TK_colour_map CornflowerBlue 100-149-237 - tcl::dict::set TK_colour_map cornsilk 255-248-220 - tcl::dict::set TK_colour_map cornsilk1 255-248-220 - tcl::dict::set TK_colour_map cornsilk2 238-232-205 - tcl::dict::set TK_colour_map cornsilk3 205-200-177 - tcl::dict::set TK_colour_map cornsilk4 139-136-120 - tcl::dict::set TK_colour_map crimson 220-20-60 - tcl::dict::set TK_colour_map cyan 0-255-255 - tcl::dict::set TK_colour_map cyan1 0-255-255 - tcl::dict::set TK_colour_map cyan2 0-238-238 - tcl::dict::set TK_colour_map cyan3 0-205-205 - tcl::dict::set TK_colour_map cyan4 0-139-139 - tcl::dict::set TK_colour_map "dark blue" 0-0-139 - tcl::dict::set TK_colour_map "dark cyan" 0-139-139 - tcl::dict::set TK_colour_map "dark goldenrod" 184-134-11 - tcl::dict::set TK_colour_map "dark gray" 169-169-169 - tcl::dict::set TK_colour_map "dark green" 0-100-0 - tcl::dict::set TK_colour_map "dark grey" 169-169-169 - tcl::dict::set TK_colour_map "dark khaki" 189-183-107 - tcl::dict::set TK_colour_map "dark magenta" 139-0-139 - tcl::dict::set TK_colour_map "dark olive green" 85-107-47 - tcl::dict::set TK_colour_map "dark orange" 255-140-0 - tcl::dict::set TK_colour_map "dark orchid" 153-50-204 - tcl::dict::set TK_colour_map "dark red" 139-0-0 - tcl::dict::set TK_colour_map "dark salmon" 233-150-122 - tcl::dict::set TK_colour_map "dark sea green" 143-188-143 - tcl::dict::set TK_colour_map "dark slate blue" 72-61-139 - tcl::dict::set TK_colour_map "dark slate gray" 47-79-79 - tcl::dict::set TK_colour_map "dark slate grey" 47-79-79 - tcl::dict::set TK_colour_map "dark turquoise" 0-206-209 - tcl::dict::set TK_colour_map "dark violet" 148-0-211 - tcl::dict::set TK_colour_map DarkBlue 0-0-139 - tcl::dict::set TK_colour_map DarkCyan 0-139-139 - tcl::dict::set TK_colour_map DarkGoldenrod 184-134-11 - tcl::dict::set TK_colour_map DarkGoldenrod1 255-185-15 - tcl::dict::set TK_colour_map DarkGoldenrod2 238-173-14 - tcl::dict::set TK_colour_map DarkGoldenrod3 205-149-12 - tcl::dict::set TK_colour_map DarkGoldenrod4 139-101-8 - tcl::dict::set TK_colour_map DarkGray 169-169-169 - tcl::dict::set TK_colour_map DarkGreen 0-100-0 - tcl::dict::set TK_colour_map DarkGrey 169-169-169 - tcl::dict::set TK_colour_map DarkKhaki 189-183-107 - tcl::dict::set TK_colour_map DarkMagenta 139-0-139 - tcl::dict::set TK_colour_map DarkOliveGreen 85-107-47 - tcl::dict::set TK_colour_map DarkOliveGreen1 202-255-112 - tcl::dict::set TK_colour_map DarkOliveGreen2 188-238-104 - tcl::dict::set TK_colour_map DarkOliveGreen3 162-205-90 - tcl::dict::set TK_colour_map DarkOliveGreen4 110-139-61 - tcl::dict::set TK_colour_map DarkOrange 255-140-0 - tcl::dict::set TK_colour_map DarkOrange1 255-127-0 - tcl::dict::set TK_colour_map DarkOrange2 238-118-0 - tcl::dict::set TK_colour_map DarkOrange3 205-102-0 - tcl::dict::set TK_colour_map DarkOrange4 139-69-0 - tcl::dict::set TK_colour_map DarkOrchid 153-50-204 - tcl::dict::set TK_colour_map DarkOrchid1 191-62-255 - tcl::dict::set TK_colour_map DarkOrchid2 178-58-238 - tcl::dict::set TK_colour_map DarkOrchid3 154-50-205 - tcl::dict::set TK_colour_map DarkOrchid4 104-34-139 - tcl::dict::set TK_colour_map DarkRed 139-0-0 - tcl::dict::set TK_colour_map DarkSalmon 233-150-122 - tcl::dict::set TK_colour_map DarkSeaGreen 43-188-143 - tcl::dict::set TK_colour_map DarkSeaGreen1 193-255-193 - tcl::dict::set TK_colour_map DarkSeaGreen2 180-238-180 - tcl::dict::set TK_colour_map DarkSeaGreen3 155-205-155 - tcl::dict::set TK_colour_map DarkSeaGreen4 105-139-105 - tcl::dict::set TK_colour_map DarkSlateBlue 72-61-139 - tcl::dict::set TK_colour_map DarkSlateGray 47-79-79 - tcl::dict::set TK_colour_map DarkSlateGray1 151-255-255 - tcl::dict::set TK_colour_map DarkSlateGray2 141-238-238 - tcl::dict::set TK_colour_map DarkSlateGray3 121-205-205 - tcl::dict::set TK_colour_map DarkSlateGray4 82-139-139 - tcl::dict::set TK_colour_map DarkSlateGrey 47-79-79 - tcl::dict::set TK_colour_map DarkTurquoise 0-206-209 - tcl::dict::set TK_colour_map DarkViolet 148-0-211 - tcl::dict::set TK_colour_map "deep pink" 255-20-147 - tcl::dict::set TK_colour_map "deep sky blue" 0-191-255 - tcl::dict::set TK_colour_map DeepPink 255-20-147 - tcl::dict::set TK_colour_map DeepPink1 255-20-147 - tcl::dict::set TK_colour_map DeepPink2 238-18-137 - tcl::dict::set TK_colour_map DeepPink3 205-16-118 - tcl::dict::set TK_colour_map DeepPink4 139-10-80 - tcl::dict::set TK_colour_map DeepSkyBlue 0-191-255 - tcl::dict::set TK_colour_map DeepSkyBlue1 0-191-255 - tcl::dict::set TK_colour_map DeepSkyBlue2 0-178-238 - tcl::dict::set TK_colour_map DeepSkyBlue3 0-154-205 - tcl::dict::set TK_colour_map DeepSkyBlue4 0-104-139 - tcl::dict::set TK_colour_map "dim gray" 105-105-105 - tcl::dict::set TK_colour_map "dim grey" 105-105-105 - tcl::dict::set TK_colour_map DimGray 105-105-105 - tcl::dict::set TK_colour_map DimGrey 105-105-105 - tcl::dict::set TK_colour_map "dodger blue" 30-144-255 - tcl::dict::set TK_colour_map DodgerBlue 30-144-255 - tcl::dict::set TK_colour_map DodgerBlue1 30-144-255 - tcl::dict::set TK_colour_map DodgerBlue2 28-134-238 - tcl::dict::set TK_colour_map DodgerBlue3 24-116-205 - tcl::dict::set TK_colour_map DodgerBlue4 16-78-139 - tcl::dict::set TK_colour_map firebrick 178-34-34 - tcl::dict::set TK_colour_map firebrick1 255-48-48 - tcl::dict::set TK_colour_map firebrick2 238-44-44 - tcl::dict::set TK_colour_map firebrick3 205-38-38 - tcl::dict::set TK_colour_map firebrick4 139-26-26 - tcl::dict::set TK_colour_map "floral white" 255-250-240 - tcl::dict::set TK_colour_map FloralWhite 255-250-240 - tcl::dict::set TK_colour_map "forest green" 34-139-34 - tcl::dict::set TK_colour_map ForestGreen 34-139-34 - tcl::dict::set TK_colour_map fuchsia 255-0-255 - tcl::dict::set TK_colour_map gainsboro 220-220-220 - tcl::dict::set TK_colour_map "ghost white" 248-248-255 - tcl::dict::set TK_colour_map GhostWhite 248-248-255 - tcl::dict::set TK_colour_map gold 255-215-0 - tcl::dict::set TK_colour_map gold1 255-215-0 - tcl::dict::set TK_colour_map gold2 238-201-0 - tcl::dict::set TK_colour_map gold3 205-173-0 - tcl::dict::set TK_colour_map gold4 139-117-0 - tcl::dict::set TK_colour_map goldenrod 218-165-32 - tcl::dict::set TK_colour_map goldenrod1 255-193-37 - tcl::dict::set TK_colour_map goldenrod2 238-180-34 - tcl::dict::set TK_colour_map goldenrod3 205-155-29 - tcl::dict::set TK_colour_map goldenrod4 139-105-20 - tcl::dict::set TK_colour_map gray 128-128-128 - tcl::dict::set TK_colour_map gray0 0-0-0 - tcl::dict::set TK_colour_map gray1 3-3-3 - tcl::dict::set TK_colour_map gray2 5-5-5 - tcl::dict::set TK_colour_map gray3 8-8-8 - tcl::dict::set TK_colour_map gray4 10-10-10 - tcl::dict::set TK_colour_map gray5 13-13-13 - tcl::dict::set TK_colour_map gray6 15-15-15 - tcl::dict::set TK_colour_map gray7 18-18-18 - tcl::dict::set TK_colour_map gray8 20-20-20 - tcl::dict::set TK_colour_map gray9 23-23-23 - tcl::dict::set TK_colour_map gray10 26-26-26 - tcl::dict::set TK_colour_map gray11 28-28-28 - tcl::dict::set TK_colour_map gray12 31-31-31 - tcl::dict::set TK_colour_map gray13 33-33-33 - tcl::dict::set TK_colour_map gray14 36-36-36 - tcl::dict::set TK_colour_map gray15 38-38-38 - tcl::dict::set TK_colour_map gray16 41-41-41 - tcl::dict::set TK_colour_map gray17 43-43-43 - tcl::dict::set TK_colour_map gray18 46-46-46 - tcl::dict::set TK_colour_map gray19 48-48-48 - tcl::dict::set TK_colour_map gray20 51-51-51 - tcl::dict::set TK_colour_map gray21 54-54-54 - tcl::dict::set TK_colour_map gray22 56-56-56 - tcl::dict::set TK_colour_map gray23 59-59-59 - tcl::dict::set TK_colour_map gray24 61-61-61 - tcl::dict::set TK_colour_map gray25 64-64-64 - tcl::dict::set TK_colour_map gray26 66-66-66 - tcl::dict::set TK_colour_map gray27 69-69-69 - tcl::dict::set TK_colour_map gray28 71-71-71 - tcl::dict::set TK_colour_map gray29 74-74-74 - tcl::dict::set TK_colour_map gray30 77-77-77 - tcl::dict::set TK_colour_map gray31 79-79-79 - tcl::dict::set TK_colour_map gray32 82-82-82 - tcl::dict::set TK_colour_map gray33 84-84-84 - tcl::dict::set TK_colour_map gray34 87-87-87 - tcl::dict::set TK_colour_map gray35 89-89-89 - tcl::dict::set TK_colour_map gray36 92-92-92 - tcl::dict::set TK_colour_map gray37 94-94-94 - tcl::dict::set TK_colour_map gray38 97-97-97 - tcl::dict::set TK_colour_map gray39 99-99-99 - tcl::dict::set TK_colour_map gray40 102-102-102 - tcl::dict::set TK_colour_map gray41 105-105-105 - tcl::dict::set TK_colour_map gray42 107-107-107 - tcl::dict::set TK_colour_map gray43 110-110-110 - tcl::dict::set TK_colour_map gray44 112-112-112 - tcl::dict::set TK_colour_map gray45 115-115-115 - tcl::dict::set TK_colour_map gray46 117-117-117 - tcl::dict::set TK_colour_map gray47 120-120-120 - tcl::dict::set TK_colour_map gray48 122-122-122 - tcl::dict::set TK_colour_map gray49 125-125-125 - tcl::dict::set TK_colour_map gray50 127-127-127 - tcl::dict::set TK_colour_map gray51 130-130-130 - tcl::dict::set TK_colour_map gray52 133-133-133 - tcl::dict::set TK_colour_map gray53 135-135-135 - tcl::dict::set TK_colour_map gray54 138-138-138 - tcl::dict::set TK_colour_map gray55 140-140-140 - tcl::dict::set TK_colour_map gray56 143-143-143 - tcl::dict::set TK_colour_map gray57 145-145-145 - tcl::dict::set TK_colour_map gray58 148-148-148 - tcl::dict::set TK_colour_map gray59 150-150-150 - tcl::dict::set TK_colour_map gray60 153-153-153 - tcl::dict::set TK_colour_map gray61 156-156-156 - tcl::dict::set TK_colour_map gray62 158-158-158 - tcl::dict::set TK_colour_map gray63 161-161-161 - tcl::dict::set TK_colour_map gray64 163-163-163 - tcl::dict::set TK_colour_map gray65 166-166-166 - tcl::dict::set TK_colour_map gray66 168-168-168 - tcl::dict::set TK_colour_map gray67 171-171-171 - tcl::dict::set TK_colour_map gray68 173-173-173 - tcl::dict::set TK_colour_map gray69 176-176-176 - tcl::dict::set TK_colour_map gray70 179-179-179 - tcl::dict::set TK_colour_map gray71 181-181-181 - tcl::dict::set TK_colour_map gray72 184-184-184 - tcl::dict::set TK_colour_map gray73 186-186-186 - tcl::dict::set TK_colour_map gray74 189-189-189 - tcl::dict::set TK_colour_map gray75 191-191-191 - tcl::dict::set TK_colour_map gray76 194-194-194 - tcl::dict::set TK_colour_map gray77 196-196-196 - tcl::dict::set TK_colour_map gray78 199-199-199 - tcl::dict::set TK_colour_map gray79 201-201-201 - tcl::dict::set TK_colour_map gray80 204-204-204 - tcl::dict::set TK_colour_map gray81 207-207-207 - tcl::dict::set TK_colour_map gray82 209-209-209 - tcl::dict::set TK_colour_map gray83 212-212-212 - tcl::dict::set TK_colour_map gray84 214-214-214 - tcl::dict::set TK_colour_map gray85 217-217-217 - tcl::dict::set TK_colour_map gray86 219-219-219 - tcl::dict::set TK_colour_map gray87 222-222-222 - tcl::dict::set TK_colour_map gray88 224-224-224 - tcl::dict::set TK_colour_map gray89 227-227-227 - tcl::dict::set TK_colour_map gray90 229-229-229 - tcl::dict::set TK_colour_map gray91 232-232-232 - tcl::dict::set TK_colour_map gray92 235-235-235 - tcl::dict::set TK_colour_map gray93 237-237-237 - tcl::dict::set TK_colour_map gray94 240-240-240 - tcl::dict::set TK_colour_map gray95 242-242-242 - tcl::dict::set TK_colour_map gray96 245-245-245 - tcl::dict::set TK_colour_map gray97 247-247-247 - tcl::dict::set TK_colour_map gray98 250-250-250 - tcl::dict::set TK_colour_map gray99 252-252-252 - tcl::dict::set TK_colour_map gray100 255-255-255 - tcl::dict::set TK_colour_map green 0-128-0 - tcl::dict::set TK_colour_map "green yellow" 173-255-47 - tcl::dict::set TK_colour_map green1 0-255-0 - tcl::dict::set TK_colour_map green2 0-238-0 - tcl::dict::set TK_colour_map green3 0-205-0 - tcl::dict::set TK_colour_map green4 0-139-0 - tcl::dict::set TK_colour_map GreenYellow 173-255-47 - tcl::dict::set TK_colour_map grey 128-128-128 - tcl::dict::set TK_colour_map grey0 0-0-0 - tcl::dict::set TK_colour_map grey1 3-3-3 - tcl::dict::set TK_colour_map grey2 5-5-5 - tcl::dict::set TK_colour_map grey3 8-8-8 - tcl::dict::set TK_colour_map grey4 10-10-10 - tcl::dict::set TK_colour_map grey5 13-13-13 - tcl::dict::set TK_colour_map grey6 15-15-15 - tcl::dict::set TK_colour_map grey7 18-18-18 - tcl::dict::set TK_colour_map grey8 20-20-20 - tcl::dict::set TK_colour_map grey9 23-23-23 - tcl::dict::set TK_colour_map grey10 26-26-26 - tcl::dict::set TK_colour_map grey11 28-28-28 - tcl::dict::set TK_colour_map grey12 31-31-31 - tcl::dict::set TK_colour_map grey13 33-33-33 - tcl::dict::set TK_colour_map grey14 36-36-36 - tcl::dict::set TK_colour_map grey15 38-38-38 - tcl::dict::set TK_colour_map grey16 41-41-41 - tcl::dict::set TK_colour_map grey17 43-43-43 - tcl::dict::set TK_colour_map grey18 46-46-46 - tcl::dict::set TK_colour_map grey19 48-48-48 - tcl::dict::set TK_colour_map grey20 51-51-51 - tcl::dict::set TK_colour_map grey21 54-54-54 - tcl::dict::set TK_colour_map grey22 56-56-56 - tcl::dict::set TK_colour_map grey23 59-59-59 - tcl::dict::set TK_colour_map grey24 61-61-61 - tcl::dict::set TK_colour_map grey25 64-64-64 - tcl::dict::set TK_colour_map grey26 66-66-66 - tcl::dict::set TK_colour_map grey27 69-69-69 - tcl::dict::set TK_colour_map grey28 71-71-71 - tcl::dict::set TK_colour_map grey29 74-74-74 - tcl::dict::set TK_colour_map grey30 77-77-77 - tcl::dict::set TK_colour_map grey31 79-79-79 - tcl::dict::set TK_colour_map grey32 82-82-82 - tcl::dict::set TK_colour_map grey33 84-84-84 - tcl::dict::set TK_colour_map grey34 87-87-87 - tcl::dict::set TK_colour_map grey35 89-89-89 - tcl::dict::set TK_colour_map grey36 92-92-92 - tcl::dict::set TK_colour_map grey37 94-94-94 - tcl::dict::set TK_colour_map grey38 97-97-97 - tcl::dict::set TK_colour_map grey39 99-99-99 - tcl::dict::set TK_colour_map grey40 102-102-102 - tcl::dict::set TK_colour_map grey41 105-105-105 - tcl::dict::set TK_colour_map grey42 107-107-107 - tcl::dict::set TK_colour_map grey43 110-110-110 - tcl::dict::set TK_colour_map grey44 112-112-112 - tcl::dict::set TK_colour_map grey45 115-115-115 - tcl::dict::set TK_colour_map grey46 117-117-117 - tcl::dict::set TK_colour_map grey47 120-120-120 - tcl::dict::set TK_colour_map grey48 122-122-122 - tcl::dict::set TK_colour_map grey49 125-125-125 - tcl::dict::set TK_colour_map grey50 127-127-127 - tcl::dict::set TK_colour_map grey51 130-130-130 - tcl::dict::set TK_colour_map grey52 133-133-133 - tcl::dict::set TK_colour_map grey53 135-135-135 - tcl::dict::set TK_colour_map grey54 138-138-138 - tcl::dict::set TK_colour_map grey55 140-140-140 - tcl::dict::set TK_colour_map grey56 143-143-143 - tcl::dict::set TK_colour_map grey57 145-145-145 - tcl::dict::set TK_colour_map grey58 148-148-148 - tcl::dict::set TK_colour_map grey59 150-150-150 - tcl::dict::set TK_colour_map grey60 153-153-153 - tcl::dict::set TK_colour_map grey61 156-156-156 - tcl::dict::set TK_colour_map grey62 158-158-158 - tcl::dict::set TK_colour_map grey63 161-161-161 - tcl::dict::set TK_colour_map grey64 163-163-163 - tcl::dict::set TK_colour_map grey65 166-166-166 - tcl::dict::set TK_colour_map grey66 168-168-168 - tcl::dict::set TK_colour_map grey67 171-171-171 - tcl::dict::set TK_colour_map grey68 173-173-173 - tcl::dict::set TK_colour_map grey69 176-176-176 - tcl::dict::set TK_colour_map grey70 179-179-179 - tcl::dict::set TK_colour_map grey71 181-181-181 - tcl::dict::set TK_colour_map grey72 184-184-184 - tcl::dict::set TK_colour_map grey73 186-186-186 - tcl::dict::set TK_colour_map grey74 189-189-189 - tcl::dict::set TK_colour_map grey75 191-191-191 - tcl::dict::set TK_colour_map grey76 194-194-194 - tcl::dict::set TK_colour_map grey77 196-196-196 - tcl::dict::set TK_colour_map grey78 199-199-199 - tcl::dict::set TK_colour_map grey79 201-201-201 - tcl::dict::set TK_colour_map grey80 204-204-204 - tcl::dict::set TK_colour_map grey81 207-207-207 - tcl::dict::set TK_colour_map grey82 209-209-209 - tcl::dict::set TK_colour_map grey83 212-212-212 - tcl::dict::set TK_colour_map grey84 214-214-214 - tcl::dict::set TK_colour_map grey85 217-217-217 - tcl::dict::set TK_colour_map grey86 219-219-219 - tcl::dict::set TK_colour_map grey87 222-222-222 - tcl::dict::set TK_colour_map grey88 224-224-224 - tcl::dict::set TK_colour_map grey89 227-227-227 - tcl::dict::set TK_colour_map grey90 229-229-229 - tcl::dict::set TK_colour_map grey91 232-232-232 - tcl::dict::set TK_colour_map grey92 235-235-235 - tcl::dict::set TK_colour_map grey93 237-237-237 - tcl::dict::set TK_colour_map grey94 240-240-240 - tcl::dict::set TK_colour_map grey95 242-242-242 - tcl::dict::set TK_colour_map grey96 245-245-245 - tcl::dict::set TK_colour_map grey97 247-247-247 - tcl::dict::set TK_colour_map grey98 250-250-250 - tcl::dict::set TK_colour_map grey99 252-252-252 - tcl::dict::set TK_colour_map grey100 255-255-255 - tcl::dict::set TK_colour_map honeydew 240-255-240 - tcl::dict::set TK_colour_map honeydew1 240-255-240 - tcl::dict::set TK_colour_map honeydew2 224-238-224 - tcl::dict::set TK_colour_map honeydew3 193-205-193 - tcl::dict::set TK_colour_map honeydew4 131-139-131 - tcl::dict::set TK_colour_map "hot pink" 255-105-180 - tcl::dict::set TK_colour_map HotPink 255-105-180 - tcl::dict::set TK_colour_map HotPink1 255-110-180 - tcl::dict::set TK_colour_map HotPink2 238-106-167 - tcl::dict::set TK_colour_map HotPink3 205-96-144 - tcl::dict::set TK_colour_map HotPink4 139-58-98 - tcl::dict::set TK_colour_map "indian red" 205-92-92 - tcl::dict::set TK_colour_map IndianRed 205-92-92 - tcl::dict::set TK_colour_map IndianRed1 255-106-106 - tcl::dict::set TK_colour_map IndianRed2 238-99-99 - tcl::dict::set TK_colour_map IndianRed3 205-85-85 - tcl::dict::set TK_colour_map IndianRed4 139-58-58 - tcl::dict::set TK_colour_map indigo 75-0-130 - tcl::dict::set TK_colour_map ivory 255-255-240 - tcl::dict::set TK_colour_map ivory1 255-255-240 - tcl::dict::set TK_colour_map ivory2 238-238-224 - tcl::dict::set TK_colour_map ivory3 205-205-193 - tcl::dict::set TK_colour_map ivory4 139-139-131 - tcl::dict::set TK_colour_map khaki 240-230-140 - tcl::dict::set TK_colour_map khaki1 255-246-143 - tcl::dict::set TK_colour_map khaki2 238-230-133 - tcl::dict::set TK_colour_map khaki3 205-198-115 - tcl::dict::set TK_colour_map khaki4 139-134-78 - tcl::dict::set TK_colour_map lavender 230-230-250 - tcl::dict::set TK_colour_map "lavender blush" 255-240-245 - tcl::dict::set TK_colour_map LavenderBlush 255-240-245 - tcl::dict::set TK_colour_map LavenderBlush1 255-240-245 - tcl::dict::set TK_colour_map LavenderBlush2 238-224-229 - tcl::dict::set TK_colour_map LavenderBlush3 205-193-197 - tcl::dict::set TK_colour_map LavenderBlush4 139-131-134 - tcl::dict::set TK_colour_map "lawn green" 124-252-0 - tcl::dict::set TK_colour_map LawnGreen 124-252-0 - tcl::dict::set TK_colour_map "lemon chiffon" 255-250-205 - tcl::dict::set TK_colour_map LemonChiffon 255-250-205 - tcl::dict::set TK_colour_map LemonChiffon1 255-250-205 - tcl::dict::set TK_colour_map LemonChiffon2 238-233-191 - tcl::dict::set TK_colour_map LemonChiffon3 205-201-165 - tcl::dict::set TK_colour_map LemonChiffon4 139-137-112 - tcl::dict::set TK_colour_map "light blue" 173-216-230 - tcl::dict::set TK_colour_map "light coral" 240-128-128 - tcl::dict::set TK_colour_map "light cyan" 224-255-255 - tcl::dict::set TK_colour_map "light goldenrod" 238-221-130 - tcl::dict::set TK_colour_map "light goldenrod yellow" 250-250-210 - tcl::dict::set TK_colour_map "light gray" 211-211-211 - tcl::dict::set TK_colour_map "light green" 144-238-144 - tcl::dict::set TK_colour_map "light grey" 211-211-211 - tcl::dict::set TK_colour_map "light pink" 255-182-193 - tcl::dict::set TK_colour_map "light salmon" 255-160-122 - tcl::dict::set TK_colour_map "light sea green" 32-178-170 - tcl::dict::set TK_colour_map "light sky blue" 135-206-250 - tcl::dict::set TK_colour_map "light slate blue" 132-112-255 - tcl::dict::set TK_colour_map "light slate gray" 119-136-153 - tcl::dict::set TK_colour_map "light slate grey" 119-136-153 - tcl::dict::set TK_colour_map "light steel blue" 176-196-222 - tcl::dict::set TK_colour_map "light yellow" 255-255-224 - tcl::dict::set TK_colour_map LightBlue 173-216-230 - tcl::dict::set TK_colour_map LightBlue1 191-239-255 - tcl::dict::set TK_colour_map LightBlue2 178-223-238 - tcl::dict::set TK_colour_map LightBlue3 154-192-205 - tcl::dict::set TK_colour_map LightBlue4 104-131-139 - tcl::dict::set TK_colour_map LightCoral 240-128-128 - tcl::dict::set TK_colour_map LightCyan 224-255-255 - tcl::dict::set TK_colour_map LightCyan1 224-255-255 - tcl::dict::set TK_colour_map LightCyan2 209-238-238 - tcl::dict::set TK_colour_map LightCyan3 180-205-205 - tcl::dict::set TK_colour_map LightCyan4 122-139-139 - tcl::dict::set TK_colour_map LightGoldenrod 238-221-130 - tcl::dict::set TK_colour_map LightGoldenrod1 255-236-139 - tcl::dict::set TK_colour_map LightGoldenrod2 238-220-130 - tcl::dict::set TK_colour_map LightGoldenrod3 205-190-112 - tcl::dict::set TK_colour_map LightGoldenrod4 139-129-76 - tcl::dict::set TK_colour_map LightGoldenrodYellow 250-250-210 - tcl::dict::set TK_colour_map LightGray 211-211-211 - tcl::dict::set TK_colour_map LightGreen 144-238-144 - tcl::dict::set TK_colour_map LightGrey 211-211-211 - tcl::dict::set TK_colour_map LightPink 255-182-193 - tcl::dict::set TK_colour_map LightPink1 255-174-185 - tcl::dict::set TK_colour_map LightPink2 238-162-173 - tcl::dict::set TK_colour_map LightPink3 205-140-149 - tcl::dict::set TK_colour_map LightPink4 139-95-101 - tcl::dict::set TK_colour_map LightSalmon 255-160-122 - tcl::dict::set TK_colour_map LightSalmon1 255-160-122 - tcl::dict::set TK_colour_map LightSalmon2 238-149-114 - tcl::dict::set TK_colour_map LightSalmon3 205-129-98 - tcl::dict::set TK_colour_map LightSalmon4 139-87-66 - tcl::dict::set TK_colour_map LightSeaGreen 32-178-170 - tcl::dict::set TK_colour_map LightSkyBlue 135-206-250 - tcl::dict::set TK_colour_map LightSkyBlue1 176-226-255 - tcl::dict::set TK_colour_map LightSkyBlue2 164-211-238 - tcl::dict::set TK_colour_map LightSkyBlue3 141-182-205 - tcl::dict::set TK_colour_map LightSkyBlue4 96-123-139 - tcl::dict::set TK_colour_map LightSlateBlue 132-112-255 - tcl::dict::set TK_colour_map LightSlateGray 119-136-153 - tcl::dict::set TK_colour_map LightSlateGrey 119-136-153 - tcl::dict::set TK_colour_map LightSteelBlue 176-196-222 - tcl::dict::set TK_colour_map LightSteelBlue1 202-225-255 - tcl::dict::set TK_colour_map LightSteelBlue2 188-210-238 - tcl::dict::set TK_colour_map LightSteelBlue3 162-181-205 - tcl::dict::set TK_colour_map LightSteelBlue4 110-123-139 - tcl::dict::set TK_colour_map LightYellow 255-255-224 - tcl::dict::set TK_colour_map LightYellow1 255-255-224 - tcl::dict::set TK_colour_map LightYellow2 238-238-209 - tcl::dict::set TK_colour_map LightYellow3 205-205-180 - tcl::dict::set TK_colour_map LightYellow4 139-139-122 - tcl::dict::set TK_colour_map lime 0-255-0 - tcl::dict::set TK_colour_map "lime green" 50-205-50 - tcl::dict::set TK_colour_map LimeGreen 50-205-50 - tcl::dict::set TK_colour_map linen 250-240-230 - tcl::dict::set TK_colour_map magenta 255-0-255 - tcl::dict::set TK_colour_map magenta1 255-0-255 - tcl::dict::set TK_colour_map magenta2 238-0-238 - tcl::dict::set TK_colour_map magenta3 205-0-205 - tcl::dict::set TK_colour_map magenta4 139-0-139 - tcl::dict::set TK_colour_map maroon 128-0-0 - tcl::dict::set TK_colour_map maroon1 255-52-179 - tcl::dict::set TK_colour_map maroon2 238-48-167 - tcl::dict::set TK_colour_map maroon3 205-41-144 - tcl::dict::set TK_colour_map maroon4 139-28-98 - tcl::dict::set TK_colour_map "medium aquamarine" 102-205-170 - tcl::dict::set TK_colour_map "medium blue" 0-0-205 - tcl::dict::set TK_colour_map "medium orchid" 186-85-211 - tcl::dict::set TK_colour_map "medium purple" 147-112-219 - tcl::dict::set TK_colour_map "medium sea green" 60-179-113 - tcl::dict::set TK_colour_map "medium slate blue" 123-104-238 - tcl::dict::set TK_colour_map "medium spring green" 0-250-154 - tcl::dict::set TK_colour_map "medium turquoise" 72-209-204 - tcl::dict::set TK_colour_map "medium violet red" 199-21-133 - tcl::dict::set TK_colour_map MediumAquamarine 102-205-170 - tcl::dict::set TK_colour_map MediumBlue 0-0-205 - tcl::dict::set TK_colour_map MediumOrchid 186-85-211 - tcl::dict::set TK_colour_map MediumOrchid1 224-102-255 - tcl::dict::set TK_colour_map MediumOrchid2 209-95-238 - tcl::dict::set TK_colour_map MediumOrchid3 180-82-205 - tcl::dict::set TK_colour_map MediumOrchid4 122-55-139 - tcl::dict::set TK_colour_map MediumPurple 147-112-219 - tcl::dict::set TK_colour_map MediumPurple1 171-130-255 - tcl::dict::set TK_colour_map MediumPurple2 159-121-238 - tcl::dict::set TK_colour_map MediumPurple3 137-104-205 - tcl::dict::set TK_colour_map MediumPurple4 93-71-139 - tcl::dict::set TK_colour_map MediumSeaGreen 60-179-113 - tcl::dict::set TK_colour_map MediumSlateBlue 123-104-238 - tcl::dict::set TK_colour_map MediumSpringGreen 0-250-154 - tcl::dict::set TK_colour_map MediumTurquoise 72-209-204 - tcl::dict::set TK_colour_map MediumVioletRed 199-21-133 - tcl::dict::set TK_colour_map "midnight blue" 25-25-112 - tcl::dict::set TK_colour_map MidnightBlue 25-25-112 - tcl::dict::set TK_colour_map "mint cream" 245-255-250 - tcl::dict::set TK_colour_map MintCream 245-255-250 - tcl::dict::set TK_colour_map "misty rose" 255-228-225 - tcl::dict::set TK_colour_map MistyRose 255-228-225 - tcl::dict::set TK_colour_map MistyRose1 255-228-225 - tcl::dict::set TK_colour_map MistyRose2 238-213-210 - tcl::dict::set TK_colour_map MistyRose3 205-183-181 - tcl::dict::set TK_colour_map MistyRose4 139-125-123 - tcl::dict::set TK_colour_map moccasin 255-228-181 - tcl::dict::set TK_colour_map "navajo white" 255-222-173 - tcl::dict::set TK_colour_map NavajoWhite 255-222-173 - tcl::dict::set TK_colour_map NavajoWhite1 255-222-173 - tcl::dict::set TK_colour_map NavajoWhite2 238-207-161 - tcl::dict::set TK_colour_map NavajoWhite3 205-179-139 - tcl::dict::set TK_colour_map NavajoWhite4 139-121-94 - tcl::dict::set TK_colour_map navy 0-0-128 - tcl::dict::set TK_colour_map "navy blue" 0-0-128 - tcl::dict::set TK_colour_map NavyBlue 0-0-128 - tcl::dict::set TK_colour_map "old lace" 253-245-230 - tcl::dict::set TK_colour_map OldLace 253-245-230 - tcl::dict::set TK_colour_map olive 128-128-0 - tcl::dict::set TK_colour_map "olive drab" 107-142-35 - tcl::dict::set TK_colour_map OliveDrab 107-142-35 - tcl::dict::set TK_colour_map OliveDrab1 192-255-62 - tcl::dict::set TK_colour_map OliveDrab2 179-238-58 - tcl::dict::set TK_colour_map OliveDrab3 154-205-50 - tcl::dict::set TK_colour_map OliveDrab4 105-139-34 - tcl::dict::set TK_colour_map orange 255-165-0 - tcl::dict::set TK_colour_map "orange red" 255-69-0 - tcl::dict::set TK_colour_map orange1 255-165-0 - tcl::dict::set TK_colour_map orange2 238-154-0 - tcl::dict::set TK_colour_map orange3 205-133-0 - tcl::dict::set TK_colour_map orange4 139-90-0 - tcl::dict::set TK_colour_map OrangeRed 255-69-0 - tcl::dict::set TK_colour_map OrangeRed1 255-69-0 - tcl::dict::set TK_colour_map OrangeRed2 238-64-0 - tcl::dict::set TK_colour_map OrangeRed3 205-55-0 - tcl::dict::set TK_colour_map OrangeRed4 139-37-0 - tcl::dict::set TK_colour_map orchid 218-112-214 - tcl::dict::set TK_colour_map orchid1 255-131-250 - tcl::dict::set TK_colour_map orchid2 238-122-233 - tcl::dict::set TK_colour_map orchid3 205-105-201 - tcl::dict::set TK_colour_map orchid4 139-71-137 - tcl::dict::set TK_colour_map "pale goldenrod" 238-232-170 - tcl::dict::set TK_colour_map "pale green" 152-251-152 - tcl::dict::set TK_colour_map "pale turquoise" 175-238-238 - tcl::dict::set TK_colour_map "pale violet red" 219-112-147 - tcl::dict::set TK_colour_map PaleGoldenrod 238-232-170 - tcl::dict::set TK_colour_map PaleGreen 152-251-152 - tcl::dict::set TK_colour_map PaleGreen1 154-255-154 - tcl::dict::set TK_colour_map PaleGreen2 144-238-144 - tcl::dict::set TK_colour_map PaleGreen3 124-205-124 - tcl::dict::set TK_colour_map PaleGreen4 84-139-84 - tcl::dict::set TK_colour_map PaleTurquoise 175-238-238 - tcl::dict::set TK_colour_map PaleTurquoise1 187-255-255 - tcl::dict::set TK_colour_map PaleTurquoise2 174-238-238 - tcl::dict::set TK_colour_map PaleTurquoise3 150-205-205 - tcl::dict::set TK_colour_map PaleTurquoise4 102-139-139 - tcl::dict::set TK_colour_map PaleVioletRed 219-112-147 - tcl::dict::set TK_colour_map PaleVioletRed1 255-130-171 - tcl::dict::set TK_colour_map PaleVioletRed2 238-121-159 - tcl::dict::set TK_colour_map PaleVioletRed3 205-104-127 - tcl::dict::set TK_colour_map PaleVioletRed4 139-71-93 - tcl::dict::set TK_colour_map "papaya whip" 255-239-213 - tcl::dict::set TK_colour_map PapayaWhip 255-239-213 - tcl::dict::set TK_colour_map "peach puff" 255-218-185 - tcl::dict::set TK_colour_map PeachPuff 255-218-185 - tcl::dict::set TK_colour_map PeachPuff1 255-218-185 - tcl::dict::set TK_colour_map PeachPuff2 238-203-173 - tcl::dict::set TK_colour_map PeachPuff3 205-175-149 - tcl::dict::set TK_colour_map PeachPuff4 139-119-101 - tcl::dict::set TK_colour_map peru 205-133-63 - tcl::dict::set TK_colour_map pink 255-192-203 - tcl::dict::set TK_colour_map pink1 255-181-197 - tcl::dict::set TK_colour_map pink2 238-169-184 - tcl::dict::set TK_colour_map pink3 205-145-158 - tcl::dict::set TK_colour_map pink4 139-99-108 - tcl::dict::set TK_colour_map plum 221-160-221 - tcl::dict::set TK_colour_map plum1 255-187-255 - tcl::dict::set TK_colour_map plum2 238-174-238 - tcl::dict::set TK_colour_map plum3 205-150-205 - tcl::dict::set TK_colour_map plum4 139-102-139 - tcl::dict::set TK_colour_map "powder blue" 176-224-230 - tcl::dict::set TK_colour_map PowderBlue 176-224-230 - tcl::dict::set TK_colour_map purple 128-0-128 - tcl::dict::set TK_colour_map purple1 155-48-255 - tcl::dict::set TK_colour_map purple2 145-44-238 - tcl::dict::set TK_colour_map purple3 125-38-205 - tcl::dict::set TK_colour_map purple4 85-26-139 - tcl::dict::set TK_colour_map red 255-0-0 - tcl::dict::set TK_colour_map red1 255-0-0 - tcl::dict::set TK_colour_map red2 238-0-0 - tcl::dict::set TK_colour_map red3 205-0-0 - tcl::dict::set TK_colour_map red4 139-0-0 - tcl::dict::set TK_colour_map "rosy brown" 188-143-143 - tcl::dict::set TK_colour_map RosyBrown 188-143-143 - tcl::dict::set TK_colour_map RosyBrown1 255-193-193 - tcl::dict::set TK_colour_map RosyBrown2 238-180-180 - tcl::dict::set TK_colour_map RosyBrown3 205-155-155 - tcl::dict::set TK_colour_map RosyBrown4 139-105-105 - tcl::dict::set TK_colour_map "royal blue" 65-105-225 - tcl::dict::set TK_colour_map RoyalBlue 65-105-225 - tcl::dict::set TK_colour_map RoyalBlue1 72-118-255 - tcl::dict::set TK_colour_map RoyalBlue2 67-110-238 - tcl::dict::set TK_colour_map RoyalBlue3 58-95-205 - tcl::dict::set TK_colour_map RoyalBlue4 39-64-139 - tcl::dict::set TK_colour_map "saddle brown" 139-69-19 - tcl::dict::set TK_colour_map SaddleBrown 139-69-19 - tcl::dict::set TK_colour_map salmon 250-128-114 - tcl::dict::set TK_colour_map salmon1 255-140-105 - tcl::dict::set TK_colour_map salmon2 238-130-98 - tcl::dict::set TK_colour_map salmon3 205-112-84 - tcl::dict::set TK_colour_map salmon4 139-76-57 - tcl::dict::set TK_colour_map "sandy brown" 244-164-96 - tcl::dict::set TK_colour_map SandyBrown 244-164-96 - tcl::dict::set TK_colour_map "sea green" 46-139-87 - tcl::dict::set TK_colour_map SeaGreen 46-139-87 - tcl::dict::set TK_colour_map SeaGreen1 84-255-159 - tcl::dict::set TK_colour_map SeaGreen2 78-238-148 - tcl::dict::set TK_colour_map SeaGreen3 67-205-128 - tcl::dict::set TK_colour_map SeaGreen4 46-139-87 - tcl::dict::set TK_colour_map seashell 255-245-238 - tcl::dict::set TK_colour_map seashell1 255-245-238 - tcl::dict::set TK_colour_map seashell2 238-229-222 - tcl::dict::set TK_colour_map seashell3 205-197-191 - tcl::dict::set TK_colour_map seashell4 139-134-130 - tcl::dict::set TK_colour_map sienna 160-82-45 - tcl::dict::set TK_colour_map sienna1 255-130-71 - tcl::dict::set TK_colour_map sienna2 238-121-66 - tcl::dict::set TK_colour_map sienna3 205-104-57 - tcl::dict::set TK_colour_map sienna4 139-71-38 - tcl::dict::set TK_colour_map silver 192-192-192 - tcl::dict::set TK_colour_map "sky blue" 135-206-235 - tcl::dict::set TK_colour_map SkyBlue 135-206-235 - tcl::dict::set TK_colour_map SkyBlue1 135-206-255 - tcl::dict::set TK_colour_map SkyBlue2 126-192-238 - tcl::dict::set TK_colour_map SkyBlue3 108-166-205 - tcl::dict::set TK_colour_map SkyBlue4 74-112-139 - tcl::dict::set TK_colour_map "slate blue" 106-90-205 - tcl::dict::set TK_colour_map "slate gray" 112-128-144 - tcl::dict::set TK_colour_map "slate grey" 112-128-144 - tcl::dict::set TK_colour_map SlateBlue 106-90-205 - tcl::dict::set TK_colour_map SlateBlue1 131-111-255 - tcl::dict::set TK_colour_map SlateBlue2 122-103-238 - tcl::dict::set TK_colour_map SlateBlue3 105-89-205 - tcl::dict::set TK_colour_map SlateBlue4 71-60-139 - tcl::dict::set TK_colour_map SlateGray 112-128-144 - tcl::dict::set TK_colour_map SlateGray1 198-226-255 - tcl::dict::set TK_colour_map SlateGray2 185-211-238 - tcl::dict::set TK_colour_map SlateGray3 159-182-205 - tcl::dict::set TK_colour_map SlateGray4 108-123-139 - tcl::dict::set TK_colour_map SlateGrey 112-128-144 - tcl::dict::set TK_colour_map snow 255-250-250 - tcl::dict::set TK_colour_map snow1 255-250-250 - tcl::dict::set TK_colour_map snow2 238-233-233 - tcl::dict::set TK_colour_map snow3 205-201-201 - tcl::dict::set TK_colour_map snow4 139-137-137 - tcl::dict::set TK_colour_map "spring green" 0-255-127 - tcl::dict::set TK_colour_map SpringGreen 0-255-127 - tcl::dict::set TK_colour_map SpringGreen1 0-255-127 - tcl::dict::set TK_colour_map SpringGreen2 0-238-118 - tcl::dict::set TK_colour_map SpringGreen3 0-205-102 - tcl::dict::set TK_colour_map SpringGreen4 0-139-69 - tcl::dict::set TK_colour_map "steel blue" 70-130-180 - tcl::dict::set TK_colour_map SteelBlue 70-130-180 - tcl::dict::set TK_colour_map SteelBlue1 99-184-255 - tcl::dict::set TK_colour_map SteelBlue2 92-172-238 - tcl::dict::set TK_colour_map SteelBlue3 79-148-205 - tcl::dict::set TK_colour_map SteelBlue4 54-100-139 - tcl::dict::set TK_colour_map tan 210-180-140 - tcl::dict::set TK_colour_map tan1 255-165-79 - tcl::dict::set TK_colour_map tan2 238-154-73 - tcl::dict::set TK_colour_map tan3 205-133-63 - tcl::dict::set TK_colour_map tan4 139-90-43 - tcl::dict::set TK_colour_map teal 0-128-128 - tcl::dict::set TK_colour_map thistle 216-191-216 - tcl::dict::set TK_colour_map thistle1 255-225-255 - tcl::dict::set TK_colour_map thistle2 238-210-238 - tcl::dict::set TK_colour_map thistle3 205-181-205 - tcl::dict::set TK_colour_map thistle4 139-123-139 - tcl::dict::set TK_colour_map tomato 255-99-71 - tcl::dict::set TK_colour_map tomato1 255-99-71 - tcl::dict::set TK_colour_map tomato2 238-92-66 - tcl::dict::set TK_colour_map tomato3 205-79-57 - tcl::dict::set TK_colour_map tomato4 139-54-38 - tcl::dict::set TK_colour_map turquoise 64-224-208 - tcl::dict::set TK_colour_map turquoise1 0-245-255 - tcl::dict::set TK_colour_map turquoise2 0-229-238 - tcl::dict::set TK_colour_map turquoise3 0-197-205 - tcl::dict::set TK_colour_map turquoise4 0-134-139 - tcl::dict::set TK_colour_map violet 238-130-238 - tcl::dict::set TK_colour_map "violet red" 208-32-144 - tcl::dict::set TK_colour_map VioletRed 208-32-144 - tcl::dict::set TK_colour_map VioletRed1 255-62-150 - tcl::dict::set TK_colour_map VioletRed2 238-58-140 - tcl::dict::set TK_colour_map VioletRed3 205-50-120 - tcl::dict::set TK_colour_map VioletRed4 139-34-82 - tcl::dict::set TK_colour_map wheat 245-222-179 - tcl::dict::set TK_colour_map wheat1 255-231-186 - tcl::dict::set TK_colour_map wheat2 238-216-174 - tcl::dict::set TK_colour_map wheat3 205-186-150 - tcl::dict::set TK_colour_map wheat4 139-126-102 - tcl::dict::set TK_colour_map white 255-255-255 - tcl::dict::set TK_colour_map "white smoke" 245-245-245 - tcl::dict::set TK_colour_map WhiteSmoke 245-245-245 - tcl::dict::set TK_colour_map yellow 255-255-0 - tcl::dict::set TK_colour_map "yellow green" 154-205-50 - tcl::dict::set TK_colour_map yellow1 255-255-0 - tcl::dict::set TK_colour_map yellow2 238-238-0 - tcl::dict::set TK_colour_map yellow3 205-205-0 - tcl::dict::set TK_colour_map yellow4 139-139-0 - tcl::dict::set TK_colour_map YellowGreen 154-205-50 - - variable TK_colour_map_lookup ;#same dict but with lower-case versions added - set TK_colour_map_lookup $TK_colour_map - dict for {key val} $TK_colour_map { - dict set TK_colour_map_lookup [tcl::string::tolower $key] $val ;#no need to test if already present - just set. - } - - variable TK_colour_map_reverse [dict create] - dict for {key val} $TK_colour_map { - dict lappend TK_colour_map_reverse $val $key - } - - #using same order as inital colour map - variable TK_colour_map_merge [dict create] - set seen_names [dict create] - dict for {key val} $TK_colour_map { - if {[dict exists $seen_names $key]} { - continue - } - set allnames [dict get $TK_colour_map_reverse $val] - set names [list] - foreach n $allnames { - if {$n ne $key} { - lappend names $n - } - } - dict set TK_colour_map_merge $key [dict create colour $val names $names] - foreach n $names { - dict set seen_names $n 1 - } - } - unset seen_names - - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace ::punk::ansi::colourmap ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval ::punk::ansi::colourmap::lib { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase - tcl::namespace::path [tcl::namespace::parent] - #*** !doctools - #[subsection {Namespace ::punk::ansi::colourmap::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 ::punk::ansi::colourmap::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - - -# ----------------------------------------------------------------------------- -# 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::ansi::colourmap -} -# ----------------------------------------------------------------------------- - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::ansi::colourmap [tcl::namespace::eval ::punk::ansi::colourmap { - variable pkg ::punk::ansi::colourmap - variable version - set version 0.1.0 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm deleted file mode 100644 index d8c43c45..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.tm +++ /dev/null @@ -1,10325 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt -# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) 2024 -# -# @@ Meta Begin -# Application punk::args 0.2 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.2] -#[copyright "2024"] -#[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] -#[require punk::args] -#[keywords module proc args arguments parse] -#[description] -#[para]Utilities for parsing proc args - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] There are many ways to parse arguments and many (too many?) packages to do it (see below for a discussion of packages and pure-tcl mechanisms). -#[para] overview of punk::args -#[subsection Concepts] -#[para]There are 2 main conventions for parsing a proc args list -#[list_begin enumerated] -#[enum] -#[para]leading option-value pairs and flags followed by a list of values (Tcl style) -#[enum] -#[para]leading list of values followed by option-value pairs and flags (Tk style) -#[list_end] -#[para]There are exceptions in both Tcl and Tk commands regarding this ordering -#[para]punk::args is focused on the 1st convention (Tcl style): parsing of the 'args' variable in leading option-value pairs (and/or solo flags) style -#[para]The proc can still contain some leading required values e.g [example "proc dostuff {arg1 arg2 args} {...}}"] -#[para]but having the core values elements at the end of args is arguably more generally useful - especially in cases where the number of trailing values is unknown and/or the proc is to be called in a functional 'pipeline' style. -#[para] -#[para]The basic principle is that a call to punk::args::parse is made near the beginning of the proc with a cacheable argument defining the parameters e.g -#[example { -# proc dofilestuff {args} { -# lassign [dict values [punk::args::parse $args withdef { -# @cmd -help "do some stuff with files e.g dofilestuff " -# @opts -type string -# #comment lines ok -# -directory -default "" -# -translation -default binary -# #setting -type none indicates a flag that doesn't take a value (solo flag) -# -nocomplain -type none -# @values -min 1 -max -1 -# }]] leaders opts values -# -# puts "translation is [dict get $opts -translation]" -# foreach f [dict values $values] { -# puts "doing stuff with file: $f" -# } -# } -#}] -#[para]The lines beginning with @ are usually optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values -#[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. -#[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. -#[para]e.g the result from the punk::args::parse call above may be something like: -#[para] leaders {} opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments -#[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments -#[para]This could also be implemented entirely using args - and the @leaders category of arguments -#[example { -# proc dofilestuff {category args} { -# lassign [dict values [punk::args::parse $args withdef { -# @id -id ::dofilestuff -# -directory -default "" -# -translation -default binary -# -nocomplain -type none -# @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 -# }]] leaders opts values -# puts "$category fileA: [dict get $values fileA]" -# puts "$category fileB: [dict get $values fileB]" -# } -#}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 -#[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, -#[para] or an additional call could be made to punk::args e.g -#[example { -# punk::args::parse [list $category $another_leading_arg] withdef { -# category -choices {cat1 cat2 cat3} -# another_leading_arg -type boolean -# } -#}] - -#*** !doctools -#[subsection Notes] -#[para]For internal functions not requiring features such as solo flags, prefix matching, type checking etc - a well crafted switch statement will be the fastest pure-tcl solution. -#[para] -#When functions are called often and/or in inner loops, a switch based solution generally makes the most sense. -#For functions that are part of an API a package may be more suitable. -#[para]The following example shows a switch-based solution that is highly performant (sub microsecond for the no-args case) -#[example { -# proc test_switch {args} { -# set opts [dict create\\ -# -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ -# -show_seps 0\\ -# -x a\\ -# -y b\\ -# -z c\\ -# -1 1\\ -# -2 2\\ -# -3 3\\ -# ] -# foreach {k v} $args { -# switch -- $k { -# -return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { -# dict set opts $k $v -# } -# default { -# error "unrecognised option '$k'. Known options [dict keys $opts]" -# } -# } -# } -# return $opts -# } -#}] -#[para]Note that the switch statement uses literals so that the compiler produces a jump-table for best performance. -#[para] -# Attempting to build the switch branch using the values from dict keys $opts will stop the jump table being built. -# To create the faster switch statement without repeating the key names, the proc body would need to be built using string map. -#[para]use punk::lib::show_jump_tables to verify that a jump table exists. -#[para]Nearly as performant due to the c-coded tcl::prefix::match function built into Tcl is the following example - which also allows shortened option names if they are unambiguous -#[example { -# proc test_prefix {args} { -# set opts [dict create\ -# -return string\ -# -frametype \uFFEF\ -# -show_edge \uFFEF\ -# -show_seps \uFFEF\ -# -x a\ -# -y b\ -# -z c\ -# -1 1\ -# -2 2\ -# -3 3\ -# ] -# if {[llength $args]} { -# set knownflags [dict keys $opts] -# } -# foreach {k v} $args { -# dict set opts [tcl::prefix::match -message "test_prefix option $k" $knownflags $k] $v -# } -# return $opts -# } -#}] -#[para]There are many alternative args parsing packages a few of which are listed here. -#[list_begin enumerated] -#[enum]argp (pure tcl) -#[enum]parse_args (c implementation) -#[enum]argparse (pure tcl *) -#[enum]cmdline (pure tcl) -#[enum]opt (pure tcl) distributed with Tcl but considered deprecated -#[enum]The tcllib set of TEPAM modules (pure tcl) -#[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. -#[list_end] -#[para] (* c implementation planned/proposed) -#[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. -#[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences -#[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. -#[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. -#[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. -#[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -#All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 -#as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. -#(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) -#ensembles: array binary clock dict info namespace string -#possibly file too, although that is generally hidden/modified in a safe interp -#chan,encoding always seems to use invokeStk1 anyway - yet there are performance improvements using ::tcl::chan::names etc -#interestingly in tcl8.7 at least - tcl::namespace::eval $somens $somescript is slightly faster than namespace eval even in unsafe interp - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::args -#[list_begin itemized] -package require Tcl 8.6- -#optional? punk::trie -#optional? punk::textblock -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -tcl::namespace::eval punk::args::register { - #*** !doctools - #[subsection {Namespace punk::args::register}] - #[para] cooperative namespace punk::args::register - #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded - #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. - #[list_begin definitions] - - #Although the actual punk::args::define calls are not too sluggish, there could be *many*. - #in a multi-interp environment, we want to be lazy about loading argdefs until they're actually required, - #especially since a fair proportion may be for documentation purposes rather than parsing args. - - # -- --- --- --- --- --- --- --- - #cooperative with packages that define some punk args but do so lazily - #These could be loaded prior to punk::args being loaded - so check existence of NAMESPACES var first - variable NAMESPACES ;#just declaring it with variable doesn't yet mean it 'exists' from 'info exists' perspective - if {![info exists ::punk::args::register::NAMESPACES]} { - set ::punk::args::register::NAMESPACES [list] - } - # -- --- --- --- --- --- --- --- - - variable loaded_packages - if {![info exists loaded_packages]} { - set loaded_packages [list] ;#fully loaded - } - variable loaded_info - if {![info exists loaded_info]} { - set loaded_info [dict create] ;#time - } - variable scanned_packages - if {![info exists scanned_packages]} { - set scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages - } - variable scanned_info ;#time and idcount - if {![info exists scanned_info]} { - set scanned_info [dict create] - } - #some packages, e.g punk::args::tclcore document other namespaces. - #when punk::args::update_definitions gets a query for a namespace - we need to load argdefs from registered sources - variable namespace_docpackages - if {![info exists namespace_docpackages]} { - set namespace_docpackages [dict create] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::register ---}] -} - -tcl::namespace::eval ::punk::args {} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args { - - - variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - - tcl::namespace::export {[a-z]*} - variable rawdef_cache - if {![info exists rawdef_cache]} { - set rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} - } - variable id_cache_rawdef - if {![info exists id_cache_rawdef]} { - set id_cache_rawdef [tcl::dict::create] - } - variable id_cache_spec - if {![info exists id_cache_spec]} { - set id_cache_spec [tcl::dict::create] - } - - variable argdefcache_unresolved - if {![info exists argdefcache_unresolved]} { - set argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) - } - - variable argdata_cache - if {![info exists argdata_cache]} { - set argdata_cache [tcl::dict::create] - } - - variable id_counter - if {![info exists id_counter]} { - set id_counter 0 - } - - #*** !doctools - #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args - #[list_begin definitions] - - #todo - some sort of punk::args::cherrypick operation to get spec from an existing set - #todo - doctools output from definition - - - - - #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix - #e.g - # -corner -aliases {-corners} - # -centre -aliases {-center -middle} - #We mightn't want the prefix to be longer just because of an alias - #we should get -co -ce and -m from the above as abbreviations - - set map [list %G% \x1b\[32m %B% \x1b\[1m %R% \x1b\[m %N% \x1b\[22m %I% \x1b\[3m %NI% \x1b\[23m ] - - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::define - #todo @preamble -help "move large block outside of table?" - @cmd -name punk::args::define -help\ - "Accepts a line-based definition of command arguments. - The definition can be supplied as a single text block or multiple as described - in the help information for 'text' below. - - Returns an id which is a key to the stored definition. - The id is taken from the supplied definition's @id -id line, or is an - automatically created id of the form 'autoid_'. - - At the time define is called - just the raw text arguments are stored for the id. - When the id is first used, for example with 'punk::args::parse $args withid $id', - the raw definition is parsed into a stored specifications dictionary. - - This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. - - This can be used purely for documentation or called within a function to parse a mix - of leading values, switches/flags and trailing values. - - The overhead is favourably comparable with other argument processors - but none are - as fast as minimal code with a switch statement. For toplevel commands where a few - 10s of microseconds is immaterial, the validation and automated error formatting in - a table can be well worthwhile. For inner procs requiring utmost speed, the call can - be made only on the unhappy path when basic processing determines a mismatch - or it - can be left entirely as documentation for interactive use with: i ... - and for synopsis generation with: s ... - - The definition should usually contain an initial line of the form: @id -id ::somecmd - - Blank lines are ignored at the top level, ie if they are not part of another structure. - Similarly - lines at the top level beginning with the # character are ignored. - All other toplevel lines must consist of a leading word followed by paired arguments. - The arguments can be spread over multiple lines and contain lines of near-arbitrary - text if they are properly braced or double quoted and Tcl escaping for inner quotes - or unbalanced braces is maintained. - The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for - a leading word. - Leading words beginning with the @ character are directives controlling argument - parsing, defaults for subsequent arguments, and help display. - directives include: - %B%@id%N% ?opt val...? - directive-options: -id - %B%@cmd%N% ?opt val...? - directive-options: -name - -summary - -help - %B%@leaders%N% ?opt val...? - (used for leading args that come before switches/opts) - directive-options: - -min -max (min and max number of leaders) - -unnamed (allow unnamed positional leaders) - -takewhenargsmodulo (assign args to leaders based on modulo - of total number of args. If value is not supplied (or < 2) then - leaders are assigned based on whether configured opts are - encountered, and whether the min number of leaders and values - can be satisfied. In this case optional leaders are assigned if - the type of the argument can be matched.) - (also accepts options as defaults for subsequent leader definitions) - %B%@opts%N% ?opt val...? - directive-options: -any|-arbitrary - (also accepts options as defaults for subsequent flag definitions) - %B%@values%N% ?opt val...? - (used for trailing args that come after switches/opts) - directive-options: -min -max -unnamed - (also accepts options as defaults for subsequent value definitions) - %B%@form%N% ?opt val...? - (used for commands with multiple forms) - directive-options: -form -synopsis - The -synopsis value allows overriding the auto-calculated - synopsis. - %B%@formdisplay%N% ?opt val...? - directive-options: -header (text for header row of table) - -body (override autogenerated arg info for form) - %B%@doc%N% ?opt val...? - directive-options: -name -url - %B%@examples%N% ?opt val...? - directive-options: -help - %B%@seealso%N% ?opt val...? - directive-options: -name -url (for footer - unimplemented) - - Some other options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults - for subsequent lines that represent your custom arguments. - These 3 directives should occur in exactly this order - but can be - repeated with custom argument lines interspersed. - - An @id line can only appear once and should be the first item. - For the commandline usage to be displayed either on parsing error - or using the i .. function - an @id with -id is needed. - - All directives can be omitted, in which case every line represents - a custom leader, value or option. - All will be leaders by default if no options defined. - If options are defined (by naming with leading dash, or explicitly - specifying @opts) then the definitions prior to the options will be - categorised as leaders, and those following the options will be - categorised as values. - - Custom arguments are defined by using any word at the start of a - line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so - that @@somearg becomes an argument named @somearg) - - custom leading args, switches/options (names starting with -) - and trailing values also take spec-options: - - -type - A typenamelist represents a multi-value clause where each - value must match the specified type in order. This is not - valid for flags - which can only take a single value. - - typename and entries in typenamelist can take 2 forms: - 1) basic form: elements of llength 1 such as a simple type, - or a pipe-delimited set of type-alternates. - e.g for a single typename: - -type int, -type int|char, -type int|literal(abc) - e.g for a typenamelist - -type {int double}, -type {int|char double} - 2) special form: elements of variable length - e.g for a single typename: - -type {{literal |}} - -type {{literal | | literal (}} - e.g for a typenamelist - -type {{literal |} {stringstartswith abc | int}} - The 2 forms can be mixed: - -type {{literal |} {stringstartswith a|c | int} literal(xyz)|int} - - Defaults to string. If no other restrictions - are required, choosing -type any does the least validation. - recognised types: - any - (unvalidated - accepts anything) - none - (used for flags/switches only. Indicates this is - a 'solo' flag ie accepts no value) - Not valid as a member of a clause's typenamelist. - int - integer - number - list - indexexpression - dict - double - float - bool - boolean - char - file - directory - ansistring - globstring - (any of the types accepted by 'string is') - - The above all perform some validation checks - - string - (also any of the 'string is' types such as - xdigit, graph, punct, lower etc) - -type string on its own does not need validation, - but still checks for string-related restrictions - such as regexprefail, & minsize - - literal() - (exact match for string) - literalprefix() - (prefix match for string, other literal and literalprefix - entries specified as alternates using | are used in the - calculation) - stringstartswith() - (value must match glob *) - The value of string must not contain pipe char '|' - - Note that types can be combined with | to indicate an 'or' - operation - e.g char|int - e.g literal(xxx)|literal(yyy) - e.g literalprefix(text)|literalprefix(binary) - (when all in the pipe-delimited type-alternates set are - literal or literalprefix - this is similar to the -choices - option) - - - and more.. (todo - document here) - If a typenamelist is supplied and has length > 1 - then -typeranges must be used instead of -range - The number of elements in -typeranges must match - the number of elements specified in -type. - - -typesynopsis - Must be same length as value in -type - This provides and override for synopsis display of types. - Any desired italicization must be applied manually to the - value. - - -optional - (defaults to true for flags/switches false otherwise) - For non flag/switch arguments - all arguments with - -optional true must sit consecutively within their group. - ie all optional leader arguments must be together, and all - optional value arguments must be together. Furthermore, - specifying both optional leaders and optional values will - often lead to ambiguous parsing results. Currently, all - optional non-flg/switch arguments should be either at the - trailing end of leaders or the trailing end of values. - Further unambiguous arrangements of optional args may be - made in future - but are currently considered 'unsupported' - -default - -multiple (for leaders & values defines whether - subsequent received values are stored against the same - argument name - only applies to final leader OR final value) - (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - not necessarily contiguously) - -choices {} - A list of allowable values for an argument. - The -default value doesn't have to be in the list. - If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted - option is set to false. If all choices are specified in values - within the -choicegroups dict, it is not necessary to specify them - in the -choices list. It is effectively a simpler form of - specifying choices when no grouping is required. It is fine to - use both -choices and -choicegroups e.g specifying all in -choices - and then including only some that need grouping in -choicegroups. - -choicelabels {} - keys are the values/argument names from -choices (or equivalently - members of value entries from the -choicegroups dict) - The values in the choicelabels dict are text values, possibly - containing newlines, that are displayed below each choice. - This is commonly a very basic summary of the choice. In the - case of a subcommand it may be a usage synopsis for further - arguments. - -choicerestricted - Whether values not specified in -choices or -choicegroups are - allowed. Defaults to true. - -choiceprefix - This specifies whether unique prefixes are able to be used - instead of the complete string. This is calculated using - tcl::prefix::match - and will display in the autogenerated - usage output. Defaults to true. - -choiceprefixdenylist {} - These choices should match exactly a choice entry in one of - the settings -choices or -choicegroups. - These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. - -choiceprefixreservelist {} - These choices are additional values used in prefix calculation. - The values will not be added to the list of available choices. - -choicegroups {} - Generally this would be used instead of -choices to allow - usage display of choices grouped by some name (or the empty - string for 'ungrouped' items which appear first). - See for example the output if 'i zlib' where choices of the - next subcommand are grouped by the names compression,channel, - streaming and checksumming. The -choices list is equivalent - to a -choicegroups dict entry where the key (groupname) is - the empty string. Both may be specified, in which case the - final list of available choices will be a union of the listed - values in -choices and the values from each choice group. - Choice values specified in -choices are effectively ungrouped - unless overridden by placing them in a choicegroup. - -choicemultiple (default {1 1}) - is a pair representing min and max number of choices - that can be present in the value. - If is a single integer it is equivalent to a - specified with the same integer for both min and max. - Max of -1 represents no upper limit. - If allows more than one choice the value is a list - consisting of items in the choices made available through - entries in -choices/-choicegroups. - -minsize (type dependant) - -maxsize (type dependant) - -range (type dependant - only valid if -type is a single item) - -typeranges (list with same number of elements as -type) - - - " - -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} - are re-evaluated on each call. - If the definition is being used not just as documentation, but is also - used within the function to parse args, e.g using punk::args::get_by_id, - then it should be noted that there is a slight performance penalty for the - dynamic case. - It is often not significant, perhaps depending on what vars/commands are - used but -dynamic true might be less desirable if the command is used in - inner loops in more performance-sensitive code. - " - @values -min 1 -max -1 - #text should be a well-formed Tcl list - text -type list -multiple 1 -help\ - {Block(s) of text representing the argument definition for a command. - At least one must be supplied. If multiple, they are joined together with \n. - Using multiple text arguments may be useful to mix curly-braced and double-quoted - strings to have finer control over interpolation when defining arguments. - (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) - - e.g the following definition passes 2 blocks as text arguments - ${[punk::args::tclcore::argdoc::example { - punk::args::define { - @id -id ::myns::myfunc - @cmd -name myns::myfunc -help\ - "Description of command" - - %G%#The following option defines an option-value pair%R% - %G%#It may have aliases by separating them with a pipe |%R% - -fg|-foreground -default blah -type string -help\ - "In the result dict returned by punk::args::parse - the value used in the opts key will always be the last - entry, in this case -foreground" - %G%#The following option defines a flag style option (solo)%R% - -flag1 -default 0 -type none -help\ - "Info about flag1 - subsequent help lines auto-dedented by whitespace to left - of corresponding record start (in this case -flag1) - + first 4 spaces if they are all present. - This line has no extra indent relative to first line 'Info about flag1' - This line indented a further 6 chars" - - @values -min 1 -max -1 - %G%#Items that don't begin with * or - are value definitions%R% - v1 -type integer -default 0 - thinglist -type string -multiple 1 - } "@doc -name Manpage: -url [myfunc_manpage_geturl myns::myfunc]"}]} - } - }]] - - proc New_command_form {name} { - #probably faster to inline a literal dict create in the proc than to use a namespace variable - set leaderdirective_defaults [tcl::dict::create\ - -type any\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -ensembleparameter 0\ - ] - set optdirective_defaults [tcl::dict::create\ - -type any\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - -prefix 1\ - -parsekey ""\ - -group ""\ - ] - #parsekey is name of argument to use as a key in punk::args::parse result dicts - - set valdirective_defaults [tcl::dict::create\ - -type any\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - - #form record can have running entries such as 'argspace' that aren't given to arg parser - #we could use {} for most default entry values - we just use {} as a hint for 'list' "" as a hint for string [tcl::dict::create] for dict - return [dict create\ - argspace "leaders"\ - ARG_INFO [tcl::dict::create]\ - ARG_CHECKS [tcl::dict::create]\ - LEADER_DEFAULTS [tcl::dict::create]\ - LEADER_REQUIRED [list]\ - LEADER_NAMES [list]\ - LEADER_MIN ""\ - LEADER_MAX ""\ - LEADER_TAKEWHENARGSMODULO 0\ - LEADER_UNNAMED false\ - LEADERSPEC_DEFAULTS $leaderdirective_defaults\ - LEADER_CHECKS_DEFAULTS {}\ - OPT_DEFAULTS [tcl::dict::create]\ - OPT_REQUIRED [list]\ - OPT_NAMES [list]\ - OPT_ANY 0\ - OPT_MIN ""\ - OPT_MAX ""\ - OPT_SOLOS {}\ - OPTSPEC_DEFAULTS $optdirective_defaults\ - OPT_CHECKS_DEFAULTS {}\ - OPT_GROUPS {}\ - VAL_DEFAULTS [tcl::dict::create]\ - VAL_REQUIRED [list]\ - VAL_NAMES [list]\ - VAL_MIN ""\ - VAL_MAX ""\ - VAL_UNNAMED false\ - VALSPEC_DEFAULTS $valdirective_defaults\ - VAL_CHECKS_DEFAULTS {}\ - FORMDISPLAY [tcl::dict::create]\ - ] - - } - - proc errorstyle {args} { - #set or query the running config -errorstyle - #review - is this an override or a default? - what happens with punk::args::parse specifically set value of -errorstyle? - #values: - #debug, enhanced, standard, basic, minimal - error todo - } - proc define {args} { - variable rawdef_cache - variable id_cache_rawdef - variable argdata_cache - if {[dict exists $rawdef_cache $args]} { - return [dict get [dict get $rawdef_cache $args] -id] - } else { - set id [rawdef_id $args] - if {[id_exists $id]} { - #we seem to be re-creating a previously defined id... - #clear any existing caches for this id - puts stderr "punk::args::define Redefinition of id:$id - clearing existing data" - - #dict unset argdata_cache $prevraw ;#silently does nothing if key not present - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - dict unset argdata_cache $k - } - } - dict for {k v} $rawdef_cache { - if {[dict get $v -id] eq $id} { - dict unset rawdef_cache $k - } - } - dict unset id_cache_rawdef $id - } - set is_dynamic [rawdef_is_dynamic $args] - set defspace [uplevel 1 {::namespace current}] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] - dict set id_cache_rawdef $id $args - return $id - } - } - - proc idquery_info {id} { - variable id_cache_rawdef - variable rawdef_cache - if {[dict exists $id_cache_rawdef $id]} { - set sep [string repeat - 40] - set rawdef [dict get $id_cache_rawdef $id] - if {[dict exists $rawdef_cache $rawdef]} { - set idinfo [dict get $rawdef_cache $rawdef] - } else { - set idinfo "" - } - set result "raw definition:" - append result \n $sep - append result \n $rawdef - append result \n $sep - append result \n "id info:" - append result \n $idinfo - append result \n $sep - variable argdata_cache - #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) - #check for and report if id is present multiple times - set argdata_records [list] - dict for {k v} $argdata_cache { - if {[dict get $v id] eq $id} { - if {$k eq $rawdef} { - lappend argdata_records [list 1 $k $v] - } else { - lappend argdata_records [list 0 $k $v] - } - } - } - append result \n "argdata cache:" - if {![llength $argdata_records]} { - append result \n "(not present)" - } else { - append result \n "present [llength $argdata_records] time(s)" - foreach r $argdata_records { - lassign $r match k v - if {$match} { - append result \n " - present with same rawdef key" - } else { - append result \n " - present with different rawdef key" - append result \n " [punk::lib::indent $k { }]" - } - } - if {[llength $argdata_records] > 1} { - append result \n "*more than one record was not expected - review*" - } - } - append result \n $sep - return $result - } - } - - proc define2 {args} { - dict get [resolve {*}$args] id - } - - proc resolve {args} { - variable rawdef_cache - variable id_cache_rawdef - set defspace "" - if {[dict exists $rawdef_cache $args]} { - set cinfo [dict get $rawdef_cache $args] - set id [dict get $cinfo -id] - set is_dynamic [dict get $cinfo -dynamic] - if {[dict exists $cinfo -defspace]} { - set defspace [dict get $cinfo -defspace] - } - } else { - #should we really be resolving something that hasn't been defined? - set id [rawdef_id $args] - puts stderr "Warning: punk::args::resolve called with undefined id:$id" - set is_dynamic [rawdef_is_dynamic $args] - dict set rawdef_cache $args [dict create -id $id -dynamic $is_dynamic] - dict set id_cache_rawdef $id $args - } - - - variable argdata_cache - variable argdefcache_unresolved - - - set cache_key $args - #ideally we would use a fast hash algorithm to produce a short key with low collision probability. - #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus but terribly slow without an accelerator) - #review - check if there is a built-into-tcl way to do this quickly - #for now we will just key using the whole string - #performance seems ok - memory usage probably not ideal - #quote from DKF 2021 - #> Dict keys can be any Tcl value; the string representation will be used as the actual value for computing the hash code. - #> It's probably a good idea to keep them comparatively short (kilobytes, not megabytes) for performance reasons, but it isn't critical. - #> There's no need to feel that the values (i.e., what they keys map to) are restricted at all. - #> You might hit overall memory limits if you compute the string representation of a very big dictionary; Tcl 8.* has limits there (in the low level API of its memory allocators). - #> If dealing with very large amounts of data, using a database is probably a good plan. - - set textargs $args - if {![llength $args]} { - punk::args::get_by_id ::punk::args::define {} - return - } - #if {[lindex $args 0] eq "-dynamic"} { - # set is_dynamic [lindex $args 1] - # set textargs [lrange $args 2 end] - #} - - #experimental - set LVL 2 - - if {!$is_dynamic} { - if {[tcl::dict::exists $argdata_cache $cache_key]} { - return [tcl::dict::get $argdata_cache $cache_key] - } - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - if {[string first \$\{ $optionspecs] > 0} { - if {$defspace ne ""} { - #normal/desired case - #set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -paramindents none -allowcommands $optionspecs]] - } else { - #todo - deprecate/stop from happening? - puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" - set optionspecs [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - } - } else { - - if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { - set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - } else { - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - #dynamic - double substitution required. - #e.g - # set DYN_CHOICES {${[::somewhere::get_choice_list]}} - # set RED [punk::ansi::a+ bold red] - # set RST [punk::ansi::a] - # punk::args::define { - # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" - #} - if {$defspace ne ""} { - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) - if {[string first \$\{ $optionspecs] > 0} { - set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel - lassign $pt_params ptlist paramlist - set optionspecs "" - foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] - } - tcl::dict::set argdefcache_unresolved $cache_key $pt_params - } - } - #argdata_cache should be limited in some fashion or will be a big memory leak??? - if {[tcl::dict::exists $argdata_cache [list $optionspecs]]} { - #resolved cache version exists - return [tcl::dict::get $argdata_cache [list $optionspecs]] - } - } - - - - #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices - #default to 1 for convenience - - #checks with no default - #-minsize -maxsize -range - - - #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi - #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist - - #set opt_defaults [tcl::dict::create] - #set val_defaults [tcl::dict::create] - - #set opt_solos [list] - #first process dashed and non-dashed record names without regard to whether non-dashed are at the beginning or end - - set records [list] - set linebuild "" - - set linelist [split $optionspecs \n] - set lastindent "" - foreach ln $linelist { - if {[tcl::string::trim $ln] eq ""} {continue} - regexp {(\s*).*} $ln _all lastindent - break ;#break at first non-empty - } - #puts "indent1:[ansistring VIEW $lastindent]" - set in_record 0 - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - foreach rawline $linelist { - set recordsofar [tcl::string::cat $linebuild $rawline] - #ansi colours can stop info complete from working (contain square brackets) - #review - when exactly are ansi codes allowed/expected in record lines. - # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" - # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket - if {$has_punkansi} { - set test_complete [punk::ansi::ansistrip $recordsofar] - } else { - #review - #we only need to strip enough to stop interference with 'info complete' - set test_complete [string map [list \x1b\[ ""] $recordsofar] - } - if {![tcl::info::complete $test_complete]} { - #append linebuild [string trimleft $rawline] \n - if {$in_record} { - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. - #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. - #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. - #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) - #(note string first "" $str is fast and returns -1) - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline \n - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline \n - } else { - append linebuild $rawline \n - } - } else { - set in_record 1 - regexp {(\s*).*} $rawline _all lastindent - #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " - append linebuild $rawline \n - } - } else { - set in_record 0 - #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - if {[tcl::string::first "$lastindent " $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline - } elseif {[tcl::string::first $lastindent $rawline] == 0} { - set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline - } else { - append linebuild $rawline - } - lappend records $linebuild - set linebuild "" - } - } - set cmd_info {} - set package_info {} - set id_info {} ;#e.g -children ?? - set doc_info {} - #set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table - set seealso_info {} - set keywords_info {} - set examples_info {} - ###set leader_min 0 - ###set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit - #set leader_max "" - #(common case of no leaders specified) - #set opt_any 0 - #set val_min 0 - #set val_max -1 ;#-1 for no limit - set DEF_definition_id $id - - #form_defs - set F [dict create _default [New_command_form _default]] - set form_ids_active [list _default] ;#list of form ids that subsequent directives and args are categorised under - - #set ARGSPACE [dict create] ;#keyed on form - #dict set ARGSPACE 0 "leaders" ;#leaders -> options -> values - - set refs [dict create] - set record_type "" - set record_number -1 ;# - foreach rec $records { - set trimrec [tcl::string::trim $rec] - switch -- [tcl::string::index $trimrec 0] { - "" - # {continue} - } - incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict - if {[llength $record_values] % 2 != 0} { - #todo - avoid raising an error - store invalid defs keyed on id - error "punk::args::resolve - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" - } - # ---------------------------------------------------------- - # we (usually) don't use form ids for some directives such as @id and @doc - but we can check and set the form ids here for each record anyway. - #We deliberately don't set form_ids_active here *with one exception* for a rename of _default on first new name encountered in any record! - #(form_ids_active is otherwise set in the @form handling block) - - #consider the following 2 line entry which is potentially dynamically included via a tstr: - # @form -form {* newform} - # @form -form {newform} -synopsis "cmd help ?stuff?" - #If we omitted the first line - it would create a new form entry depending on whether it was the first record in the target location with a -form key or not. - #(because _default is usually 'taken over' by the first encountered form id) - #With both lines included - the first one matches all existing form ids, so newform is guaranteed to be a new record - #the first line will set all ids active - so the second line is necessary to bring it back to just newform - and have the -synopsis applied only to that record. - - if {[dict exists $record_values -form] && [llength [dict get $record_values -form]] > 0} { - set patterns [dict get $record_values -form] - set record_form_ids [list] - foreach p $patterns { - if {[regexp {[*?\[\]]} $p]} { - #isglob - only used for matching existing forms - lappend record_form_ids {*}[lsearch -all -inline -glob [dict keys $F] $p] - } else { - #don't test for existence - will define new form if necessary - lappend record_form_ids $p - } - } - #-form values could be globs that didn't match. record_form_ids could be empty.. - if {[llength $record_form_ids]} { - #only rename _default if it's the sole entry - if {[dict size $F] == 1 && [dict exists $F "_default"]} { - if {"_default" ni $record_form_ids} { - #only initial form exists - but we are mentioning new ones - #first rename the _default to first encountered new form id - #(just replace whole dict with new key - same data) - set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] - #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F - #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] - } - } - foreach fid $record_form_ids { - if {![dict exists $F $fid]} { - if {$firstword eq "@form"} { - #only @form directly supplies keys - dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] - } else { - dict set F $fid [New_command_form $fid] - } - } else { - #update form with current record opts, except -form - if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } - } - } - } - } else { - #missing or empty -form - set record_form_ids $form_ids_active - if {$firstword eq "@form"} { - foreach fid $form_ids_active { - dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] - } - } - } - # ---------------------------------------------------------- - - set firstchar [tcl::string::index $firstword 0] - set secondchar [tcl::string::index $firstword 1] - if {$firstchar eq "@" && $secondchar ne "@"} { - set record_type "directive" - set directive_name $firstword - set at_specs $record_values - - switch -- [tcl::string::range $directive_name 1 end] { - dynamic { - set is_dynamic 1 - } - id { - #disallow duplicate @id line ? - #review - nothing to stop multiple @id lines - or redefining as auto (which is ignored?) - - #id An id will be allocated if no id line present or the -id value is "auto" - - if {[dict exists $at_specs -id]} { - set thisid [dict get $at_specs -id] - if {$thisid ni [list $id auto]} { - error "punk::args::resolve @id mismatch existing: $id vs $thisid" - } - } - set id_info $at_specs - } - ref { - #a reference within the definition - #e.g see punk::args::tclcore ::after - #global reference dict - independent of forms - #ignore refs without an -id - #store all keys except -id - #complete overwrite if refid repeated later on - if {[dict exists $at_specs -id]} { - dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] - } - } - default { - #NOTE - this is switch arm for the literal "default" (@default) - not the default arm of the switch block! - - #copy from an identified set of *resolved*?? defaults (another argspec id) can be multiple - #(if we were to take from a definition - we would have to check and maybe change this def to -dynamic.. ?) - #perhaps we could allow -dynamic as a flag here - but IFF this define is already -dynamic (?) - #That is possibly too complicated and/or unnecessary? - #however.. as it stands we have define @dynamic making *immediate* resolutions .. is that really desirable? - - if {[dict exists $at_specs -id]} { - set copyfrom [get_spec [dict get $at_specs -id]] - #we don't copy the @id info from the source - #for now we only copy across if nothing set.. - #todo - bring across defaults for empty keys at targets? - #need to keep it simple enough to reason about behaviour easily.. - if {[dict size $copyfrom]} { - if {![dict size $cmd_info]} { - set cmd_info [dict get $copyfrom cmd_info] - } - if {![dict size $doc_info]} { - set doc_info [dict get $copyfrom doc_info] - } - - #foreach fid $record_form_ids { - # #only use elements with matching form id? - # #probably this feature mainly useful for _default anyway so that should be ok - # #cooperative doc sets specified in same file could share via known form ids too - # FORMDISPLAY has keys -header -body - # if {![dict size $F $fid $FORMDISPLAY]} { - # if {[dict exists $copyfrom FORMS $fid FORMDISPLAY]} { - # dict set F $fid FORMDISPLAY [dict get $copyfrom FORMS $fid FORMDISPLAY] - # } - # } - # #TODO - # #create leaders opts vals depending on position of @default line? - # #options on @default line to exclude/include sets??? - #} - } - } - } - form { - # arity system ? - #handle multiple parsing styles based on arities and keyword positions (and/or flags?) - #e.g see lseq manual with 3 different parsing styles. - - # @form "-synopsis" is optional - and only exists in case the user really wants - # to display something different. The system should generate consistent synopses - # with appropriate italics/bracketing etc. - # For manual -synopsis - features such as italics must be manually added. - - #spitballing.. - #The punk::args parser should generally be able to determine the appropriate form based - #on supplied arguments, e.g automatically using argument counts and matching literals. - #We may need to support some hints for forcing more efficient -form discriminators - # - # e.g compare with -takewhenargsmodulo that is available on @leaders - - #the -arities idea below is a rough one; potentially something to consider.. but - #we want to be able to support command completion.. and things like literals should probably - #take preference for partially typed commands.. as flipping to other forms based on argcount - #could be confusing. Need to match partial command to closest form automatically but allow - #user to lock in a form interactively and see mismatches (?) - #Probably the arity-ranges of a form are best calculated automatically rather than explicitly, - #otherwise we have a strong potential for misdefinition.. (conflict with defined leaders,opts,values) - #The way forward might be to calculate some 'arity' structure from the forms to aid in form-discrimination at arg parse time. - #(this is currently covered in some ways by the LEADER_MIN,LEADER_MAX,OPT_MIN,OPT_MAX,VAL_MIN,VAL_MAX members of the FORMS dict.) - - # @form -synopsis "start ?('..'|'to')? end ??'by'? step?"\ - # -arities { - # 2 - # {3 anykeys {1 .. 1 to}} - # {4 anykeys {3 by}} - # {5 anykeys {1 .. 1 to 3 by}} - # }\ - # -fallback 1 - # ... - # @parser -synopsis "start 'count' count ??'by'? step?"\ - # -arities { - # {3 anykeys {1 count}} - # } - # ... - # @form -synopsis "count ?'by' step?"\ - # -arities { - # 1 - # {3 anykeys {1 by}} - # } - # - # see also after manual - # @form -arities {1} - # @form -arities { - # 1 anykeys {0 info} - # } - #todo - - - #form id can be list of ints|names?, or * - if {[dict exists $at_specs -form]} { - set idlist [dict get $at_specs -form] - if {$idlist eq "*"} { - #* only applies to form ids that exist at the time - set idlist [dict keys $F] - } - set form_ids_active $idlist - } - #new form keys already created if they were needed (done for all records that have -form ) - } - package { - set package_info [dict merge $package_info $at_specs] - } - cmd { - #allow arbitrary - review - #e.g -name - # -summary - # -help - set cmd_info [dict merge $cmd_info $at_specs] - } - doc { - set doc_info [dict merge $doc_info $at_specs] - } - formdisplay { - #override the displayed argument table for the form. - #(formdisplay keys -header -body) - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - foreach fid $record_form_ids { - tcl::dict::set F $fid FORMDISPLAY [dict merge [tcl::dict::get $F $fid FORMDISPLAY] $at_specs] - } - } - opts { - foreach fid $record_form_ids { - if {[tcl::dict::get $F $fid argspace] eq "values"} { - error "punk::args::resolve - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" - } - tcl::dict::set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid OPTSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -any - -arbitrary - - -anyopts { - #set opt_any $v - tcl::dict::set F $fid OPT_ANY $v - } - -min { - dict set F $fid OPT_MIN $v - } - -max { - #if no -max explicitly specified, and llength OPT_NAMES == 0 and OPT_ANY == 0 - -max will be set to 0 below. - dict set F $fid OPT_MAX $v - } - -minsize - -maxsize - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted { - #review - only apply to certain types? - tcl::dict::set tmp_optspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels - -nocase { - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_optspec_defaults $k2 - } - } - -type { - #v is a typelist - #foreach t $v { - # #validate? - #} - tcl::dict::set tmp_optspec_defaults -type $v - } - -defaultdisplaytype { - #how the -default is displayed - #-default doesn't have to be the same type as -type which validates user input that is not defaulted. - tcl::dict::set tmp_optspec_defaults -defaultdisplaytype $v - } - -parsekey { - tcl::dict::set tmp_optspec_defaults -parsekey $v - - } - -group { - tcl::dict::set tmp_optspec_defaults -group $v - if {$v ne "" && ![tcl::dict::exists $F $fid OPT_GROUPS $v]} { - tcl::dict::set F $fid OPT_GROUPS $v {-parsekey {} -help {}} - } - if {$v ne ""} { - if {[tcl::dict::exists $at_specs -parsekey]} { - tcl::dict::set F $fid OPT_GROUPS $v -parsekey [tcl::dict::get $at_specs -parsekey] - } - } - } - -grouphelp { - if {![tcl::dict::exists $at_specs -group]} { - error "punk::args::resolve Bad @opt line. -group entry is required if -grouphelp is being configured. @id:$DEF_definition_id" - } - set g [tcl::dict::get $at_specs -group] - if {$g eq ""} { - error "punk::args::resolve Bad @opt line. -group non-empty value is required if -grouphelp is being configured. @id:$DEF_definition_id" - } - set groupdict [tcl::dict::get $F $fid OPT_GROUPS] - #set helprecords [tcl::dict::get $F $fid OPT_GROUPS_HELP] - if {![tcl::dict::exists $groupdict $g]} { - tcl::dict::set F $fid OPT_GROUPS $g [dict create -parsekey {} -help $v] - } else { - tcl::dict::set F $fid OPT_GROUPS $g -help $v - } - } - -range { - if {[dict exists $at_specs -type]} { - set tp [dict get $at_specs -type] - } else { - set tp [dict get $tmp_optspec_defaults -type] - } - if {[llength $tp] == 1} { - tcl::dict::set tmp_optspec_defaults -typeranges [list $v] - } else { - error "punk::args::resolve Bad @opt line. -type has length [llength $tp] (-type $tp). -range only applies to single-item type. Use -typeranges instead. @id:$DEF_definition_id" - } - } - -typeranges { - if {[dict exists $at_specs -type]} { - set tp [dict get $at_specs -type] - } else { - set tp [dict get $tmp_optspec_defaults -type] - } - if {[llength $tp] != [llength $v]} { - error "punk::args::resolve Bad @opt line. -type has length [llength $tp] (-type $tp). -typeranges has length [llength $v]. Lengths must match. @id:$DEF_definition_id" - } - tcl::dict::set tmp_optspec_defaults -typeranges $v - } - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -validationtransform { - #allow overriding of defaults for options that occur later - tcl::dict::set tmp_optspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -multiple - - -prefix { - #check is bool - if {![string is boolean -strict $v]} { - error "punk::args::resolve - Option '$k' has value '$v'of wrong type in @opts line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_optspec_defaults $k $v - } - default { - set known { -parsekey -group -grouphelp\ - -any -anyopts -arbitrary -form -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ - -type -range -typeranges -default -defaultdisplaytype -typedefaults - -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple -prefix\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::resolve - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" - } - } - } - tcl::dict::set F $fid OPTSPEC_DEFAULTS $tmp_optspec_defaults - } ;# end foreach record_form_ids - } - leaders { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] in [list options values]} { - error "punk::args::resolve - @leaders declaration must come before all options and values (command form: '$fid') id:$DEF_definition_id" - } - set tmp_leaderspec_defaults [dict get $F $fid LEADERSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::resolve - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MIN $v - #if {$leader_max == 0} { - # set leader_max -1 - #} - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::resolve - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$DEF_definition_id" - } - dict set F $fid LEADER_MAX $v - } - -takewhenargsmodulo { - dict set F $fid LEADER_TAKEWHENARGSMODULO $v - } - -choiceprefix - - -choicerestricted { - if {![string is boolean -strict $v]} { - error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -choiceinfo - -choicelabels { - if {[llength $v] %2 != 0} { - error "punk::args::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - #-choicegroups? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_leaderspec_defaults $k2 - } - } - -type { - #$v is a list of types - #foreach t $v { - #validate? - #} - #switch -- $v { - # int - integer { - # set v int - # } - # char - character { - # set v char - # } - # bool - boolean { - # set v bool - # } - # dict - dictionary { - # set v dict - # } - # list { - - # } - # index { - # set v indexexpression - # } - # default { - # #todo - disallow unknown types unless prefixed with custom- - # } - #} - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -range { - tcl::dict::set tmp_leaderspec_defaults -range $v - } - -typeranges { - tcl::dict::set tmp_leaderspec_defaults -range $v - } - -minsize - -maxsize - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefixdenylist - -choiceprefixreservelist - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform { - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -multiple { - if {![string is boolean -strict $v]} { - error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -unnamed { - if {![string is boolean -strict $v]} { - error "punk::args::resolve - invalid type of value '$v' for key '$k' in @leaders line. Must be boolean @id:$DEF_definition_id" - } - dict set F $fid LEADER_UNNAMED $v - } - -ensembleparameter { - #review - tcl::dict::set tmp_leaderspec_defaults $k $v - #error "punk::args::resolve - -ensembleparameter not supported as a default for @leaders - only valid on actual leader arguments" - } - default { - set known { -min -form -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ - -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ - -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -unnamed\ - } - error "punk::args::resolve - unrecognised key '$k' in @leaders line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid LEADERSPEC_DEFAULTS $tmp_leaderspec_defaults - - } ;#end foreach record_form_ids - - } - values { - foreach fid $record_form_ids { - dict set F $fid argspace "values" - - set tmp_valspec_defaults [dict get $F $fid VALSPEC_DEFAULTS] - - foreach {k v} $at_specs { - switch -- $k { - -form { - #review - handled above - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::resolve - minimum acceptable value for key '$k' in @values line is 0. got $v @id:$DEF_definition_id" - } - #set val_min $v - dict set F $fid VAL_MIN $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::resolve - minimum acceptable value for key '$k' in @values line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" - } - #set val_max $v - dict set F $fid VAL_MAX $v - } - -minsize - -maxsize - -choices - -choicemultiple - -choicecolumns - - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_valspec_defaults $k $v - } - -choiceinfo - -choicegroups { - if {[llength $v] % 2 != 0} { - error "punk::args::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { - # -choicegroups ?? - if {$v} { - set k2 -[string range $k 3 end] ;#strip 'no' - tcl::dict::unset tmp_valspec_defaults $k2 - } - } - -type { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - index { - set v indexexpression - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -range { - tcl::dict::set tmp_valspec_defaults -range $v - } - -typeranges { - tcl::dict::set tmp_valspec_defaults -typeranges $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -multiple { - if {![string is boolean -strict $v]} { - error "punk::args::resolve - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform { - tcl::dict::set tmp_valspec_defaults $k $v - } - -unnamed { - if {![string is boolean -strict $v]} { - error "punk::args::resolve - invalid type of value '$v' for key '$k' in @values line. Must be boolean @id:$DEF_definition_id" - } - dict set F $fid VAL_UNNAMED $v - } - default { - set known { -type -range -typeranges\ - -min -form -minvalues -max -maxvalues\ - -minsize -maxsize\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo\ - -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ - -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -unnamed\ - } - error "punk::args::resolve - unrecognised key '$k' in @values line. Known keys: $known @id:$DEF_definition_id" - } - } - } - dict set F $fid VALSPEC_DEFAULTS $tmp_valspec_defaults - } - - } - seealso { - #todo! - #like @doc, except displays in footer, multiple - sub-table? - set seealso_info [dict merge $seealso_info $at_specs] - } - keywords { - #review - put as option on @cmd instead? @cmd -name xxx -keywords {blah etc hmm} ?? - set keywords_info [dict merge $keywords_info $at_specs] - } - examples { - set examples_info [dict merge $examples_info $at_specs] - } - default { - error "punk::args::resolve - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @examples @formdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" - } - } - #record_type directive - continue - } elseif {$firstchar eq "-"} { - set argdef_values $record_values - #Note that we can get options defined with aliases e.g "-x|-suppress" - #Here we store the full string as the argname - but in the resulting dict upon parsing it will have the final - # entry as the key for retrieval e.g {leaders {} opts {-suppress true} values {} ...} - - #we can also have longopts within the list e.g "-f|--filename=" - #This accepts -f or --filename= - # (but not --filename ) - #if the clausemember is optional - then the flag can act as a solo, but a parameter can only be specified on the commandline with an = - #e.g "-x|--something= -type ?string? - #accepts all of: - # -x - # --something - # --something=blah - - - #while most longopts require the = some utilities (e.g fossil) - #accept --longname - #(fossil accepts either --longopt or --longopt=) - #For this reason, "-f|--filename" is different to gnu-style longopt "-f|--filename=" - - #for "--filename=" we can specify an 'optional' clausemember using for example -type ?string? - - #4? cases - #1) - #--longopt - # (not really a longopt - can only parse with --longopt - [optional member not supported, but could be solo if -type none]) - #2) - #--longopt= - # (gnu style longopt - parse with --longopt= - solo allowed if optional member - does not support solo via -type none) - #3) - #--longopt|--longopt= -types int - # (mixed - as fossil does - parse with --longopt= or --longopt [optional member not supported?]) - #4) - # --xxx|--longopt= -types {?int?} - #(repeating such as --longopt --longopt= not valid?) - #redundant? - #ie --longopt|--longopt= -types {?int?} - # equivalent to - # --longopt= -types {?int?} - #allow parsing -xxx only as solo and --longopt as solo or --longopt=n ? - - #the above set would not cover the edge-case where we have an optional member but we don't want --longopt to be allowed solo - #e.g - #-soloname|--longopt= -types ?int? - #allows parsing "-soloname" or "--longopt" or "--longopt=n" - #but what if we want it to mean only accept: - # "-soloname" or "--longopt=n" ?? - - #we deliberately don't support - #--longopt -type ?type? - #or -opt -type ?type? - #as this results in ambiguities and more complexity in parsing depending on where flag occurs in args compared to positionals - - #for these reasons - we can't only look for leading -- here to determine 'longopt' - - - set argname $firstword - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - #do some basic validation here - #1 "-type none" would not be valid for "--filename=" - #2 a -type can only be optional (specified as -type ?xxx?) if at least one entry in the argname has a trailing = - #3 require --longopt if has a trailing =. ie disallow -opt= ? - - set has_equal 0 - set optaliases [split $firstword |] - if {[lsearch $optaliases *=] >=0} { - set has_equal 1 - } - #todo - if no -type specified in this flag record, we still need to check the default -type from the @opts record - which could have been - #overridden from just 'string' - if {[tcl::dict::exists $argdef_values -type]} { - set tp [tcl::dict::get $argdef_values -type] - if {[llength $tp] != 1} { - #clauselength > 1 not currently supported for flags - #e.g -myflag -type {list int} - # e.g called on commandline with cmd -myflag {a b c} 3 - #review - seems an unlikely and complicating feature to allow - evidence of tools using/supporting this in the wild not known of. - error "punk::args::resolve - Multiple space-separated arguments (as indicated by -type having multiple entries) for a flag are not supported. flag $argname -type '$tp' @id:$DEF_definition_id" - } - if {$argname eq "--"} { - if {$tp ne "none"} { - #error to explicitly attempt to configure -- as a value-taking option - error "punk::args::resolve - special flag named -- cannot be configured as a value-accepting flag. set -type none or omit -type from definition. @id:$DEF_definition_id" - } - } - if {$tp eq "none"} { - if {$has_equal} { - error "punk::args::resolve - flag type 'none' (indicating non-parameter-taking flag) is not supported when any flag member ends with = (indicating gnu-longopt style possibly taking a parameter). flag $argname -type '$tp' @id:$DEF_definition_id" - } - } elseif {[string match {\?*\?} $tp]} { - #optional flag value - if {!$has_equal} { - error "punk::args::resolve - Optional flag parameter (as indicated by leading & trailing ?) is not supported when no flag member ends with = (indicating gnu-longopt style possibly taking a parameter). flag $argname -type '$tp' @id:$DEF_definition_id" - } - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - ##set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] - - tcl::dict::set argdef_values -ARGTYPE option - #set all_choices [_resolve_get_record_choices] - - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - dict set F $fid argspace "options" - } elseif {[dict get $F $fid argspace] eq "values"} { - error "punk::args::resolve - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" - } - set record_type option - - dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] - } - - set is_opt 1 - } else { - set argname $firstword - if {$firstchar eq "@"} { - #allow basic @@ escaping for literal argname that begins with @ - set argname [tcl::string::range $argname 1 end] - } - - set argdef_values $record_values - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "leaders"} { - set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader - #lappend leader_names $argname - set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] - if {$argname ni $temp_leadernames} { - lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames - } else { - #This can happen if the definition has repeated values - error "punk::args::resolve - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - - if {[dict get $F $fid LEADER_MAX] >= 0} { - if {[dict get $F $fid LEADER_MAX] < [llength $temp_leadernames]} { - puts stderr "punk::args::resolve warning arg $argname LEADER_MAX == [dict get $F $fid LEADER_MAX] but [llength $temp_leadernames] leader names found @id:$DEF_definition_id" - dict set F $fid LEADER_MAX [llength $temp_leadernames] - } - } - } else { - set record_type value - tcl::dict::set argdef_values -ARGTYPE value - set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] - if {$argname ni $temp_valnames} { - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames - } else { - error "punk::args::resolve - arg $argname already present as value in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - #lappend val_names $argname - if {[dict get $F $fid VAL_MAX] >= 0} { - if {[dict get $F $fid VAL_MAX] < [llength $temp_valnames]} { - puts stderr "punk::args::resolve warning arg $argname VAL_MAX == [dict get $F $fid VAL_MAX] but [llength $temp_valnames] value names found @id:$DEF_definition_id" - dict set F $fid VAL_MAX [llength $temp_valnames] - } - } - } - } - - set is_opt 0 - } - - - #assert - we only get here if it is a leader, value or flag specification line. - #assert argdef_values has been set to the value of record_values - - foreach fid $record_form_ids { - if {$is_opt} { - set spec_merged [dict get $F $fid OPTSPEC_DEFAULTS] - } else { - if {[dict get $F $fid argspace] eq "values"} { - set spec_merged [dict get $F $fid VALSPEC_DEFAULTS] - } else { - set spec_merged [dict get $F $fid LEADERSPEC_DEFAULTS] - } - } - - # -> argopt argval - foreach {spec specval} $argdef_values { - #literal-key switch - bytecompiled to jumpTable - switch -- $spec { - -form {} - -type { - #todo - could be a list e.g {any int literal(Test)} - #case must be preserved in literal bracketed part - set typelist [list] - foreach typespec $specval { - if {[string match {\?*\?} $typespec]} { - set tspec [string range $typespec 1 end-1] - set optional_clausemember true - } else { - set tspec $typespec - set optional_clausemember false - } - set type_alternatives [_split_type_expression $tspec] - set normlist [list] - foreach alt $type_alternatives { - set firstword [lindex $alt 0] - set lc_firstword [tcl::string::tolower $firstword] - #normalize here so we don't have to test during actual args parsing in main function - set normtype "" ;#assert - should be overridden in all branches of switch - switch -- $lc_firstword { - int - integer {set normtype int} - double - float { - #review - user may wish to preserve 'float' in help display - consider how best to implement - set normtype double - } - bool - boolean {set normtype bool} - char - character {set normtype char} - dict - dictionary {set normtype dict} - index - indexexpression {set normtype indexexpression} - "" - none - solo { - if {$is_opt} { - #review - are we allowing clauses for flags? - #e.g {-flag -type {int int}} - #this isn't very tcl like, where we'd normally mark the flag with -multiple true and - # instead require calling as: -flag -flag - #It seems this is a reasonably rare/unlikely requirement in most commandline tools. - - if {[llength $specval] > 1} { - #makes no sense to have 'none' in a clause - error "punk::args::resolve - invalid -type '$specval' for flag '$argname' ('none' in multitype) @id:$DEF_definition_id" - } - #tcl::dict::set spec_merged -type none - set normtype none - if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { - tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. - } - } else { - #solo only valid for flags - error "punk::args::resolve - invalid -type 'none|solo' for positional argument '$argname' (only valid for flags/options) @id:$DEF_definition_id" - } - } - any - anything {set normtype any} - ansi - ansistring {set normtype ansistring} - string - globstring {set normtype $lc_firstword} - literal { - #value was split out by _split_type_expression - set normtype literal([lindex $alt 1]) - } - literalprefix { - set normtype literalprefix([lindex $alt 1]) - } - stringstartswith { - set normtype stringstartswith([lindex $alt 1]) - } - stringendswith { - set normtype stringendswith([lindex $alt 1]) - } - default { - #allow custom unknown types through for now. Todo - require unknown types to begin with custom- REVIEW - #tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - #todo - set normtype $alt - } - } - lappend normlist $normtype - } - set norms [join $normlist |] - if {$optional_clausemember} { - lappend typelist ?$norms? - } else { - lappend typelist $norms - } - } - tcl::dict::set spec_merged -type $typelist - } - -typesynopsis { - set typecount [llength [tcl::dict::get $spec_merged -type]] - if {$typecount != [llength $specval]} { - error "punk::args::resolve - invalid -typesynopsis specification for argument '$argname'. -typesynopsis has [llength $specval] entries, but requires $typecount entries (one for each entry in -types. Use empty string list members for default) @id:$DEF_definition_id" - } - tcl::dict::set spec_merged -typesynopsis $specval - } - -parsekey - -group { - tcl::dict::set spec_merged -typesynopsis $specval - } - -solo - - -choices - -choicegroups - -choicemultiple - -choicecolumns - - -choiceprefix - -choiceprefixdenylist - -choiceprefixreservelist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -multiple - - -validate_ansistripped - -allow_ansi - -strip_ansi - -help - -ARGTYPE - - -regexprepass - -regexprefail - -regexprefailmsg - { - #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines - #review -solo 1 vs -type none ? conflicting values? - tcl::dict::set spec_merged $spec $specval - } - -range { - #allow simple case to be specified without additional list wrapping - #only multi-types require full list specification - #arg1 -type int -range {0 4} - #arg2 -type {int string} -range {{0 4} {"" ""}} - set typecount [llength [tcl::dict::get $spec_merged -type]] - if {$typecount == 1} { - tcl::dict::set spec_merged -typeranges [list $specval] - } else { - error "punk::args::resolve Bad @opt line. -type has length [llength $tp] (-type $tp). -range only applies to single-item type. Use -typeranges instead. @id:$DEF_definition_id" - } - } - -typeranges { - set typecount [llength [tcl::dict::get $spec_merged -type]] - if {$typecount != [llength $specval]} { - error "punk::args::resolve - invalid -typeranges specification for argument '$argname'. -typeranges has [llength $specval] entries, but requires $typecount entries (one for each entry in -types) @id:$DEF_definition_id" - } - tcl::dict::set spec_merged -typeranges $specval - } - -default { - #The -default is for when the entire clause is missing - #It doesn't necessarily have to have the same number of elements as the clause {llength $typelist} - #review - tcl::dict::set spec_merged -default $specval - if {![dict exists $argdef_values -optional]} { - tcl::dict::set spec_merged -optional 1 - } - } - -defaultdisplaytype { - tcl::dict::set spec_merged -defaultdisplaytype $specval - } - -typedefaults { - set typecount [llength [tcl::dict::get $spec_merged -type]] - if {$typecount != [llength $specval]} { - error "punk::args::resolve - invalid -typedefaults specification for argument '$argname'. -typedefaults has [llength $specval] entries, but requires $typecount entries (one for each entry in -types) @id:$DEF_definition_id" - } - tcl::dict::set spec_merged -typedefaults $specval - } - -optional { - #applies to whole arg - not each -type - tcl::dict::set spec_merged -optional $specval - } - -ensembleparameter { - #applies to whole arg - not each -type - #review - only leaders? - tcl::dict::set spec_merged $spec $specval - } - -prefix { - #applies to whole arg - not each -type - #for flags/options - tcl::dict::set spec_merged $spec $specval - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::resolve - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" - } - dict for {tk tv} $specval { - switch -- $tk { - -command - -function - -type - -minsize - -maxsize - -range { - } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::resolve - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" - } - } - } - #TODO! - - } - default { - if {[string match ref-* $spec]} { - #we don't validate keys taken from refs - this is a way to apply arbitrary keys to argdefs (classify as a feature-bug or an optimisation for now) - #ref-xxx will override an earlier -xxx in same line. That's fine. todo - document. - if {![tcl::dict::exists $refs $specval]} { - puts stderr "punk::args::resolve argument '$argname' attempt to reference non-existing @ref -id $specval (with $spec)" - } else { - set targetswitch [string range $spec 3 end] ;#capture - to form flag "-" - if {$targetswitch eq "-*"} { - set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id - } else { - if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] - } else { - puts stderr "punk::args::resolve argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" - } - } - } - } else { - set known_argopts [list\ - -form -type\ - -parsekey -group\ - -range -typeranges\ - -default -defaultdisplaytype -typedefaults\ - -minsize -maxsize -choices -choicegroups\ - -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choiceprefixreservelist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - -ensembleparameter\ - ] - error "punk::args::resolve - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argopts @id:$DEF_definition_id" - } - } - } - } ;# end foreach {spec specval} argdef_values - - - if {$is_opt} { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize - if {$argname eq "--"} { - #force -type none - in case no -type was specified and @opts -type is some other default such as string - tcl::dict::set spec_merged -type none - } - if {[tcl::dict::get $spec_merged -type] eq "none"} { - dict set F $fid OPT_SOLOS [list {*}[dict get $F $fid OPT_SOLOS] $argname] - } - } else { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi -choicecolumns -group -typesynopsis -help -ARGTYPE] ;#leave things like -range -minsize - } - tcl::dict::set F $fid ARG_INFO $argname $spec_merged - #review existence of -default overriding -optional - #if {![tcl::dict::get $spec_merged -optional] && ![tcl::dict::exists $spec_merged -default]} {} - if {![tcl::dict::get $spec_merged -optional]} { - if {$is_opt} { - set temp_opt_required [dict get $F $fid OPT_REQUIRED] - lappend temp_opt_required $argname - dict set F $fid OPT_REQUIRED $temp_opt_required - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - set temp_leader_required [dict get $F $fid LEADER_REQUIRED] - lappend temp_leader_required $argname - dict set F $fid LEADER_REQUIRED $temp_leader_required - } else { - set temp_val_required [dict get $F $fid VAL_REQUIRED] - lappend temp_val_required $argname - dict set F $fid VAL_REQUIRED $temp_val_required - } - } - } - - - if {[tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - #JJJ - set parsekey [dict get $F $fid ARG_INFO $argname -default] - if {$parsekey eq ""} { - set parsekey $argname - } - tcl::dict::set F $fid OPT_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - if {[dict get $F $fid argspace] eq "leaders"} { - tcl::dict::set F $fid LEADER_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } else { - tcl::dict::set F $fid VAL_DEFAULTS $argname [tcl::dict::get $spec_merged -default] - } - } - } - } ;# end foreach fid record_form_ids - - } ;# end foreach rec $records - - - #if {$DEF_definition_id eq "" || [tcl::string::tolower $DEF_definition_id] eq "auto"} { - # variable id_counter - # set DEF_definition_id "autoid_[incr id_counter]" - #} - - - #now cycle through ALL forms not just form_ids_active (record_form_ids) - dict for {fid formdata} $F { - if {[tcl::dict::get $F $fid OPT_MAX] eq ""} { - if {[llength [tcl::dict::get $F $fid OPT_NAMES]] == 0 && ![tcl::dict::get $F $fid OPT_ANY]} { - tcl::dict::set F $fid OPT_MAX 0 ;#aid in parsing to avoid scanning for opts unnecessarily - #review - when using resolved_def to create a definiation based on another - OPT_MAX may need to be overridden - a bit ugly? - } - } - # REVIEW - #no values specified - we can allow last leader to be multiple - foreach leadername [lrange [tcl::dict::get $F $fid LEADER_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername' in command form:'$fid'. Only the last leader argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - - #todo - disallow any -multiple == true entries if any leaders have -multiple == true? - #(creates parsing ambiguity) - #ambiguity could be resolved if at least one required option/flag eg -- - #ambiguities could theoretically also be resolved with required literals or choices - or even based on argument type - #(overcomplex? todo see if any core/tcllib commands work like that) - - #only allow a single entry within VAL_NAMES to have -multiple == true - #example of command with non-trailing -multiple == true is core command: 'file copy ?-force? ?--? source ?source?... targetDir - set val_multiples 0 - foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - if {$val_multiples > 0} { - error "bad setting -multiple true on argument spec for value '$valname' in command form:'$fid'. Only a single value argument specification can be marked with -multiple true @id:$DEF_definition_id" - } - incr val_multiples - } - } - - #todo - document that ambiguities in API are likely if both @leaders and @values used - #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - - - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata LEADERSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata OPTSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata VALSPEC_DEFAULTS] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - } - - - - - #todo - precalculate a set of 'arity' entries for each form - #We want a structure for the arg parser to get easy access and make a fast decision on which form applies - #eg a classifier assistant might be total_arity ranges (where -1 is unlimited) ? - #1) after ms (1 1) - #2) after ms ?script...? (1 -1) (or is it 2 -1 ??) - should actually be #after ms script ?script...? - #3) after cancel id (2 2) - #4) after cancel script ?script...? (2 -1) - #5) after idle script ?script...? (1 -1) - #6) after info ?id? (1 2) - - #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - - #in the above case we have no unique total_arity - #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" - # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - - - - set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use - #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from - - set form_info [dict create] - dict for {fid fdict} $F { - dict set form_info $fid {} - dict for {optk optv} $fdict { - if {[string match -* $optk]} { - dict set form_info $fid $optk $optv - } - } - } - - set argdata_dict [tcl::dict::create\ - id $DEF_definition_id\ - cmd_info $cmd_info\ - doc_info $doc_info\ - package_info $package_info\ - seealso_info $seealso_info\ - keywords_info $keywords_info\ - examples_info $examples_info\ - id_info $id_info\ - FORMS $F\ - form_names [dict keys $F]\ - form_info $form_info\ - ] - - tcl::dict::set argdata_cache $cache_key $argdata_dict - if {$is_dynamic} { - #also cache resolved version - tcl::dict::set argdata_cache [list $optionspecs] $argdata_dict - } - - #tcl::dict::set id_cache_rawdef $DEF_definition_id $args - #puts "xxx:$result" - return $argdata_dict - } - - #return raw definition list as created with 'define' - # - possibly with unresolved dynamic parts - proc raw_def {id} { - variable id_cache_rawdef - set realid [real_id $id] - if {![dict exists $id_cache_rawdef $realid]} { - return "" - } - return [tcl::dict::get $id_cache_rawdef $realid] - } - - - namespace eval argdoc { - variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @examples @formdisplay @seealso @leaders @opts @values leaders opts values} - variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @examples @formdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} - } - - lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { - @id -id ::punk::args::resolved_def - @cmd -name punk::args::resolved_def -help\ - "Resolves or retrieves the previously resolved definition and - uses the 'spec' form to build a response in definition format. - - Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with - care. - - Note that the directives @leaders @opts @values may appear multiple - times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for - each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before - the arguments of that type - but this doesn't mean there was a single - leading directive for this argument type in the source definition. - Each argument has already had its complete specification recorded in - its own result. - - When manually specifying -types, the order @leaders then @opts then - @values must be maintained - but if they are placed before their - corresponding arguments, they will not affect the retrieved arguments - as these arguments are already fully spec'd. The defaults from the - source can be removed by adding @leaders, @opts @values to the - -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the - -override dictionary. - " - @leaders -min 0 -max 0 - @opts - -return -default text -choices {text dict} - -form -default 0 -help\ - "Ordinal index or name of command form" - - #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} - -antiglobs -default {} -type list -help\ - "Glob patterns for directive or argument/flags to - be suppressed" - -override -type dict -optional 1 -default "" -help\ - "dict of dicts. Key in outer dict is the name of a - directive or an argument. Inner dict is a map of - overrides/additions (- ...) for that line. - " - @values -min 1 -max -1 - id -type string -help\ - "identifer for a punk::args definition - This will usually be a fully-qualifed - path for a command name" - pattern -type string -optional 1 -default * -multiple 1 -help\ - "glob-style patterns for retrieving value or switch - definitions. - - If -type is * and pattern is * the entire definition including - directive lines will be returned in line form. - (directives are lines beginning with - @ e.g @id, @cmd etc) - - if -type is leaders,opts or values matches from that type - will be returned. - - if -type is another directive such as @id, @doc etc the - patterns are ignored. - - " - }]] - } - - - proc resolved_def {args} { - #not eating our own dogfood here as far as argument parsing. -id ::punk::args::resolved_def is for documentation/errors only. - set opts [dict create\ - -return text\ - -types {}\ - -form 0\ - -antiglobs {}\ - -override {}\ - ] - if {[llength $args] < 1} { - #must have at least id - punk::args::parse $args withid ::punk::args::resolved_def - return - } - set patterns [list] - - #a definition id must not begin with "-" ??? review - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {$a in {-type -types}} { - incr i - dict set opts -types [lindex $args $i] - } elseif {[string match -* $a]} { - incr i - dict set opts $a [lindex $args $i] - } else { - set id [lindex $args $i] - set patterns [lrange $args $i+1 end] - break - } - if {$i == [llength $args]-1} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - if {![llength $patterns]} { - set patterns [list *] - } - dict for {k v} $opts { - #set fullk [tcl::prefix::match -error "" {-return -form -types -antiglobs -override} $k] - switch -- $k { - -return - -form - -types - -antiglobs - -override {} - default { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - } - set typelist [dict get $opts -types] - if {[llength $typelist] == 0} { - set typelist {*} - } - foreach type $typelist { - if {$type ni $::punk::args::argdoc::resolved_def_TYPE_CHOICES} { - punk::args::parse $args withid ::punk::args::resolved_def - return - } - } - - - variable id_cache_rawdef - set realid [real_id $id] - if {$realid eq ""} { - return - } - - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - set opt_form [dict get $opts -form] - if {[string is integer -strict $opt_form]} { - set formname [lindex [dict get $specdict form_names] $opt_form] - } else { - set formname $opt_form - } - set opt_override [dict get $opts -override] - set opt_return [dict get $opts -return] - - #set arg_info [dict get $specdict ARG_INFO] - set arg_info [dict get $specdict FORMS $formname ARG_INFO] - set argtypes [dict create leaders leader opts option values value] - - set opt_antiglobs [dict get $opts -antiglobs] - set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] - set suppressed_directives [list] - set suppressed_args [list] - foreach ag $opt_antiglobs { - foreach d $directives { - if {[string match $ag $d]} { - lappend suppressed_directives $d - } - } - foreach argname [dict keys $arg_info] { - if {[string match $ag $argname]} { - lappend suppressed_args $argname - } - } - } - set suppressed_directives [lsort -unique $suppressed_directives] - set suppressed_args [lsort -unique $suppressed_args] - - set included_directives [punk::args::system::punklib_ldiff $directives $suppressed_directives] - - set globbed [list] - foreach pat $patterns { - set matches [dict keys $arg_info $pat] - lappend globbed {*}$matches - } - set globbed [lsort -unique $globbed] - #maintain order of original arg_info keys in globbed results - set ordered_globbed [list] - foreach a [dict keys $arg_info] { - if {$a ni $ordered_globbed && $a in $globbed} { - lappend ordered_globbed $a - } - } - set included_args [punk::args::system::punklib_ldiff $ordered_globbed $suppressed_args] - - set result "" - set resultdict [dict create] - foreach type $typelist { - switch -exact -- $type { - * { - if {"@id" in $included_directives} { - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - foreach directive {@package @cmd @doc @examples @seealso} { - set dshort [string range $directive 1 end] - if {"$directive" in $included_directives} { - if {[dict exists $opt_override $directive]} { - append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict ${dshort}_info]" - dict set resultdict $directive [dict get $specdict ${dshort}_info] - } - } - } - - #todo @formdisplay - #todo @ref ? - - - #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" - switch -- $directive { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - - if {"$directive" in $included_directives} { - if {[dict exists $opt_override "$directive"]} { - append result \n "$directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict FORMS $formname $defaults_key]" - dict set resultdict $directive [dict get $specdict FORMS $formname $defaults_key] - } - } - - if {$pseudodirective in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq $tp} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "\"$m\" [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "\"$m\" $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - - } - @id { - if {"@id" in $included_directives} { - #only a single id record can exist - if {[dict exists $opt_override @id]} { - append result \n "@id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]]" - dict set resultdict @id [dict merge [dict create -id [dict get $specdict id]] [dict get $opt_override @id]] - } else { - append result \n "@id -id [dict get $specdict id]" - dict set resultdict @id [list -id [dict get $specdict id]] - } - } - } - @package - @cmd - @doc - @examples - @seealso { - if {"$type" in $included_directives} { - set tp [string range $type 1 end] ;# @package -> package - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict ${tp}_info] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict ${tp}_info]" - dict set resultdict $type [dict get $specdict ${tp}_info] - } - } - #todo @formdisplay - } - @leaders - @opts - @values { - #these are the active defaults for further arguments - if {"$type" in $included_directives} { - switch -- $type { - @leaders {set defaults_key LEADERSPEC_DEFAULTS} - @opts {set defaults_key OPTSPEC_DEFAULTS} - @values {set defaults_key VALSPEC_DEFAULTS} - } - if {[dict exists $opt_override $type]} { - append result \n "$type [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict FORMS $formname $defaults_key] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict FORMS $formname $defaults_key]" - dict set resultdict $type [dict get $specdict FORMS $formname $defaults_key] - } - } - } - leaders - opts - values { - #pseudo-directives - if {$type in $included_directives} { - foreach m $included_args { - set argspec [dict get $arg_info $m] - if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { - set argspec [dict remove $argspec -ARGTYPE] - if {[dict exists $opt_override $m]} { - append result \n "\"$m\" [dict merge $argspec [dict get $opt_override $m]]" - dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] - } else { - append result \n "\"$m\" $argspec" - dict set resultdict $m $argspec - } - } - } - } - } - default { - } - } - if {$opt_return eq "text"} { - return $result - } else { - return $resultdict - } - } - } - - proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef - set realid [real_id $id] - if {$realid ne ""} { - set deflist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [resolve {*}$deflist] - set arg_info [dict get $specdict ARG_INFO] - set valnames [dict get $specdict VAL_NAMES] - set result "" - if {$patternlist eq "*"} { - foreach v $valnames { - set def [dict get $arg_info $v] - set def [dict remove $def -ARGTYPE] - append result \n "$v $def" - } - return $result - } else { - foreach pat $patternlist { - set matches [dict keys $arg_info $pat] - set matches [lsearch -all -inline -glob $valnames $pat] - foreach m $matches { - set def [dict get $arg_info $m] - set def [dict remove $def -ARGTYPE] - append result \n "$m $def" - } - } - return $result - } - } - } - #proc resolved_def_leaders ?? - #proc resolved_def_opts ?? - - proc get_spec {id} { - set deflist [raw_def $id] - if {$deflist eq ""} { - return - } - return [resolve {*}$deflist] - #if {[id_exists $id]} { - # return [resolve {*}[raw_def $id]] - #} - } - proc is_dynamic {id} { - variable id_cache_rawdef - variable rawdef_cache - set deflist [raw_def $id] - if {[dict exists $rawdef_cache $deflist -dynamic]} { - return [dict get $rawdef_cache $deflist -dynamic] - } - return [rawdef_is_dynamic $deflist] - #@dynamic only has meaning as 1st element of a def in the deflist - } - - #@id must be within first 4 lines of a block - or assign auto - #review - @dynamic block where -id not explicitly set? - disallow? - proc rawdef_id {rawdef} { - set id "" - foreach d $rawdef { - foreach ln [lrange [split $d \n] 0 4] { - if {[regexp {\s*(\S+)(.*)} $ln _match firstword rest]} { - if {$firstword eq "@id"} { - if {[llength $rest] %2 == 0 && [dict exists $rest -id]} { - set id [dict get $rest -id] - break - } - } - } - } - if {$id ne ""} { - break - } - } - if {$id eq "" || [string tolower $id] eq "auto"} { - variable id_counter - set id "autoid_[incr id_counter]" - } - #puts "==>id: $id" - return $id - } - #test the rawdef for @dynamic directive - proc rawdef_is_dynamic {rawdef} { - #temporary - old way - set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ] - if {$flagged_dynamic} { - return true - } - foreach d $rawdef { - if {[regexp {\s*(\S+)} $d _match firstword]} { - if {$firstword eq "@dynamic"} { - return true - } - } - } - return false - } - - variable aliases - set aliases [dict create] - - lappend PUNKARGS [list { - @id -id ::punk::args::get_ids - @cmd -name punk::args::get_ids -help\ - "return list of ids for argument definitions" - @values -min 0 -max 1 - match -default * -help\ - "exact id or glob pattern for ids" - }] - proc get_ids {{match *}} { - variable id_cache_rawdef - variable aliases - return [list {*}[tcl::dict::keys $aliases $match] {*}[tcl::dict::keys $id_cache_rawdef $match]] - } - - #we don't automatically test for (autodef)$id - only direct ids and aliases - proc id_exists {id} { - variable aliases - if {[tcl::dict::exists $aliases $id]} { - return 1 - } - variable id_cache_rawdef - tcl::dict::exists $id_cache_rawdef $id - } - proc aliases {} { - variable aliases - punk::lib::showdict $aliases - } - proc set_alias {alias id} { - variable aliases - dict set aliases $alias $id - } - proc unset_alias {alias} { - variable aliases - dict unset aliases $alias - } - proc get_alias {alias} { - variable aliases - if {[dict exists $aliases $alias]} { - return [tcl::dict::get $aliases $alias] - } - } - - proc real_id {id} { - variable id_cache_rawdef - variable aliases - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } else { - set check_updates [list [namespace qualifiers $id]] - #puts stderr "---->real_id '$id' update_definitions $check_updates" - if {![llength [update_definitions $check_updates]]} { - #nothing new loaded - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } else { - if {[tcl::dict::exists $aliases $id]} { - set id [tcl::dict::get $aliases $id] - } - if {[tcl::dict::exists $id_cache_rawdef $id]} { - return $id - } - if {[tcl::dict::exists $id_cache_rawdef (autodef)$id]} { - return (autodef)$id - } - return "" - } - } - } - - proc status {} { - upvar ::punk::args::register::NAMESPACES registered - upvar ::punk::args::register::loaded_packages loaded_packages - upvar ::punk::args::register::loaded_info loaded_info - upvar ::punk::args::register::scanned_packages scanned_packages - upvar ::punk::args::register::scanned_info scanned_info - set result "" - # [format %-${w0}s $idtail] - set widest [tcl::mathfunc::max {*}[lmap v [list {*}$registered "Registered"] {string length $v}]] - append result "[format %-${widest}s Registered] Scanned_ids Scantime_us Loaded_defs Loadtime_us" \n - set width_c2 [string length "Scanned_ids"] - set width_c3 [string length "Scantime_us"] - set width_c4 [string length "Loaded_defs"] - set width_c5 [string length "Loadtime_us"] - set count_unloaded 0 - set count_loaded 0 - foreach ns $registered { - if {$ns in $scanned_packages} { - set ids [dict get $scanned_info $ns idcount] - set scan_us [dict get $scanned_info $ns time] - } else { - set ids "" - set scan_us "" - } - if {$ns in $loaded_packages} { - incr count_loaded - set ldefs [dict get $loaded_info $ns defcount] - set load_us [dict get $loaded_info $ns time] - } else { - incr count_unloaded - set ldefs "" - set load_us "" - } - append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n - } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" - return $result - } - - lappend PUNKARGS [list { - @id -id ::punk::args::update_definitions - @cmd -name punk::args::update_definitions\ - -summary\ - ""\ - -help\ - "" - @values -min 1 - id - arglist -type list -help\ - "list containing arguments to be parsed as per the - argument specification identified by the supplied id." - }] - #scanned_packages (list) - #namespace_docpackages (dict) - proc update_definitions {{nslist *}} { - #puts "----> update_definitions '$nslist'" - if {[set gposn [lsearch $nslist {}]] >= 0} { - lset nslist $gposn :: - } - upvar ::punk::args::register::NAMESPACES registered ;#list - upvar ::punk::args::register::loaded_packages loaded_packages ;#list - upvar ::punk::args::register::loaded_info loaded_info ;#dict - upvar ::punk::args::register::scanned_packages scanned_packages ;#list - upvar ::punk::args::register::scanned_info scanned_info ;#dict - upvar ::punk::args::register::namespace_docpackages namespace_docpackages ;#dict - - - #puts stderr "-->update_definitions '$nslist'" - #needs to run quickly - especially when no package namespaces to be scanned for argdefs - #e.g - gets called for each subcommand of an ensemble (could be many) - # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. - #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- - # common-case fast-path - - if {[llength $loaded_packages] == [llength $registered]} { - #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. - #assert - if all are registered - then all have been scanned - return {} - } - # -- --- --- --- --- --- - - set unscanned [punklib_ldiff $registered $scanned_packages] - if {[llength $unscanned]} { - foreach pkgns $unscanned { - set idcount 0 - set ts_start [clock microseconds] - if {[info exists ${pkgns}::PUNKARGS]} { - set seen_documentedns [list] ;#seen per pkgns - foreach definitionlist [set ${pkgns}::PUNKARGS] { - #namespace eval $evalns [list punk::args::define {*}$definitionlist] - set id [rawdef_id $definitionlist] - if {[string match autoid_* $id]} { - puts stderr "update_definitions - unexpected autoid during scan of $pkgns - skipping" - puts stderr "definition:\n" - foreach d $definitionlist { - set out "" - foreach ln [split $d \n] { - append out " " $ln \n - } - puts $out - } - continue - } - #todo - detect duplicate ids (last will silently win.. should be reported somewhere) - incr idcount - set documentedns [namespace qualifiers $id] - if {$documentedns eq ""} {set documentedns ::} - if {$documentedns ni $seen_documentedns} { - #don't add own ns as a key in namespace_docpackages - if {$documentedns ne $pkgns} { - dict lappend namespace_docpackages $documentedns $pkgns - } - lappend seen_documentedns $documentedns - } - } - } - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - dict set scanned_info $pkgns [dict create time $diff idcount $idcount] - #we count it as scanned even if PUNKARGS didn't exist - #(registered the namespace, variable PUNKARGS may or may not be declared, but didn't set PUNKARGS) - lappend scanned_packages $pkgns - } - } - - - - if {"*" in $nslist} { - set needed [punklib_ldiff $registered $loaded_packages] - } else { - set needed [list] - foreach pkgns $nslist { - if {![string match ::* $pkgns]} { - puts stderr "warning: update_definitions received unqualified ns: $pkgns" - set pkgns ::$pkgns - } - if {$pkgns in $registered && $pkgns ni $loaded_packages} { - lappend needed $pkgns - } - #argdoc sub namespace is a standard place to put defs that match the namespace below - #(generally the PUNKARGS in a namespace should apply to own ns) - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns - } - } - if {[dict exists $namespace_docpackages $pkgns]} { - #this namespace has other argdef sources - foreach docns [dict get $namespace_docpackages $pkgns] { - if {$docns ni $loaded_packages} { - lappend needed $docns - } - } - } - } - } - - - - set newloaded [list] - foreach pkgns $needed { - #puts stderr "update_definitions Loading: $pkgns" - set ts_start [clock microseconds] - set def_count 0 - if {![catch { - if {[info exists ${pkgns}::PUNKARGS]} { - set docns ${pkgns}::argdoc - if {[namespace exists $docns]} { - namespace eval ${pkgns}::argdoc { - set epath [namespace path] - set pkgns [namespace parent] - if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail - } - - } - set evalns $docns - } else { - set evalns $pkgns - } - foreach definitionlist [set ${pkgns}::PUNKARGS] { - namespace eval $evalns [list punk::args::define {*}$definitionlist] - incr def_count - } - } - - #process list of 2-element lists - if {[info exists ${pkgns}::PUNKARGS_aliases]} { - foreach adef [set ${pkgns}::PUNKARGS_aliases] { - punk::args::set_alias {*}$adef - } - } - } errMsg]} { - set ts_end [clock microseconds] - set diff [expr {$ts_end - $ts_start}] - lappend loaded_packages $pkgns - lappend newloaded $pkgns - dict set loaded_info $pkgns [dict create time $diff defcount $def_count] - } else { - puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" - } - } - return $newloaded - } - - #for use within get_dict only - #This mechanism gets less-than-useful results for oo methods - #e.g {$obj} - proc Get_caller {} { - set depth [info level] - set maxd [expr {min($depth,4)}] - set call_level [expr {-1 * $maxd}] - #set call_level -3 ;#for get_dict call - #set call_level -4 - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - #puts "-->$cmdinfo" - #puts "-->[tcl::info::frame -3]" - set maxloop 10 ;#failsafe - while {[string last \n $cmdinfo] >= 1 && $maxloop > -1} { - #looks like a script - haven't gone up far enough? - #(e.g patternpunk oo system: >punk . poses -invalidoption) - incr call_level -1 - if {[catch { - set nextup [tcl::info::frame $call_level] - } ]} { - break - } - set cmdinfo [tcl::dict::get $nextup cmd] - set caller [regexp -inline {\S+} $cmdinfo] - if {[interp alias {} $caller] ne ""} { - #puts "found alias for caller $caller to [interp alias {} $caller]" - #see if we can go further - incr call_level -1 - if {[catch { - set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd] - } errM ]} { - puts "err: $errM" - break - } - } - incr maxloop -1 - } - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - # review - message? - set cmdinfo "Get_caller (punk::args::get_dict?) called from namespace" - } - return $cmdinfo - } - - - # -------------------------------------- - #test of Get_caller - lappend PUNKARGS [list { - @id -id ::punk::args::test1 - @values -min 0 -max 0 - }] - proc test_get_dict {args} { - punk::args::get_dict [punk::args::raw_def ::punk::args::test1] $args - } - proc test_get_by_id {args} { - punk::args::get_by_id ::punk::args::test1 $args - } - #supply an arg to cause usage error for test functions - check initial message to see if Get_caller is correct. - proc test_callers {args} { - if {![llength $args]} { - puts "these test functions accept no arguments" - puts "Call with arg(s) to compare error output" - } - - if {[catch {test_get_dict {*}$args} errM]} { - puts $errM - } - puts "------------" - if {[catch {test_get_by_id {*}$args} errM]} { - puts $errM - } - return done - } - # -------------------------------------- - - set map "" - lappend PUNKARGS [list [string map $map { - @id -id ::punk::args::arg_error - @cmd -name punk::args::arg_error -help\ - "Generates a table (by default) of usage information for a command. - A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept - a defined set of choices. These prefixes match the mechanism used - to validate arguments (based on tcl::prefix::match). - - This function is called during the argument parsing process - (if the definition is not only being used for documentation) - It is also called by punk::args::usage which is in turn - called by the punk::ns introspection facilities which creates - on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. - " - @leaders -min 2 -max 2 - msg -type string -help\ - "Error message to display immediately prior to usage table. - May be empty string to just display usage. - " - spec_dict -type dict -help\ - "Dictionary of argument specifications. - This is the internal format parsed from - the textual definition. It contains the data - organised/optimised to allow the final arg - parser/validator to make decisions. - " - @opts - -badarg -type string -help\ - "name of an argument to highlight" - -parsedargs -type dict -help\ - "Result of successful punk::pargs::parse - (currently only looks at 'received')" - -aserror -type boolean -help\ - "If true, the usage table is raised as an error message, - otherwise it is returned as a value." - -return -choices {string table tableobject} -choicelabels { - string "no table layout" - tableobject "table object cmd" - table "full table layout" - } - -scheme -default error -choices {nocolour info error} - -form -default 0 -help\ - "Ordinal index or name of command form" - }] ] - - - variable arg_error_CLR - array set arg_error_CLR {} - variable arg_error_CLR_nocolour - array set arg_error_CLR_nocolour {} - variable arg_error_CLR_info - array set arg_error_CLR_info {} - variable arg_error_CLR_error - array set arg_error_CLR_error {} - - proc _argerror_load_colours {{forcereload 0}} { - variable arg_error_CLR - #todo - option for reload/retry? - if {!$forcereload && [array size arg_error_CLR] > 0} { - return - } - - if {[catch {package require punk::ansi} errMsg]} { - puts stderr "punk::args FAILED to load punk::ansi\n$errMsg" - proc ::punk::args::a {args} {} - proc ::punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } - #array set arg_error_CLR {} - set arg_error_CLR(testsinglecolour) [a+ yellow] ;#A single SGR colour to test current colour on|off state (empty string vs some result - used to determine if forcereload required) - set arg_error_CLR(errormsg) [a+ brightred] - set arg_error_CLR(title) "" - set arg_error_CLR(check) [a+ brightgreen] - set arg_error_CLR(solo) [a+ brightcyan] - set arg_error_CLR(choiceprefix) [a+ underline] - set arg_error_CLR(badarg) [a+ brightred] - set arg_error_CLR(goodarg) [a+ green strike] - set arg_error_CLR(goodchoice) [a+ reverse] - set arg_error_CLR(linebase_header) [a+ white] - set arg_error_CLR(linebase) [a+ white] - set arg_error_CLR(cmdname) [a+ brightwhite] - set arg_error_CLR(groupname) [a+ bold] - set arg_error_CLR(ansiborder) [a+ bold] - set arg_error_CLR(ansibase_header) [a+ bold] - set arg_error_CLR(ansibase_body) [a+ white] - variable arg_error_CLR_nocolour - #array set arg_error_CLR_nocolour {} - set arg_error_CLR_nocolour(errormsg) [a+ bold] - set arg_error_CLR_nocolour(title) [a+ bold] - set arg_error_CLR_nocolour(check) "" - set arg_error_CLR_nocolour(solo) "" - set arg_error_CLR_nocolour(badarg) [a+ reverse] ;#? experiment - set arg_error_CLR_nocolour(goodarg) [a+ strike] - set arg_error_CLR_nocolour(cmdname) [a+ bold] - set arg_error_CLR_nocolour(linebase_header) "" - set arg_error_CLR_nocolour(linebase) "" - set arg_error_CLR_nocolour(ansibase_body) "" - variable arg_error_CLR_info - #array set arg_error_CLR_info {} - set arg_error_CLR_info(errormsg) [a+ brightred bold] - set arg_error_CLR_info(title) [a+ brightyellow bold] - set arg_error_CLR_info(check) [a+ brightgreen bold] - set arg_error_CLR_info(choiceprefix) [a+ brightgreen bold] - set arg_error_CLR_info(groupname) [a+ cyan bold] - set arg_error_CLR_info(ansiborder) [a+ brightcyan bold] - set arg_error_CLR_info(ansibase_header) [a+ cyan] - set arg_error_CLR_info(ansibase_body) [a+ white] - variable arg_error_CLR_error - #array set arg_error_CLR_error {} - set arg_error_CLR_error(errormsg) [a+ brightred bold] - set arg_error_CLR_error(title) [a+ brightcyan bold] - set arg_error_CLR_error(check) [a+ brightgreen bold] - set arg_error_CLR_error(choiceprefix) [a+ brightgreen bold] - set arg_error_CLR_error(groupname) [a+ cyan bold] - set arg_error_CLR_error(ansiborder) [a+ brightyellow bold] - set arg_error_CLR_error(ansibase_header) [a+ yellow] - set arg_error_CLR_error(ansibase_body) [a+ white] - } - - - #bas ic recursion blocker - variable arg_error_isrunning 0 - proc arg_error {msg spec_dict args} { - #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. - #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args - #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. - #consider per-namespace or namespace-tree configurability. - #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. - #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling - #code which has no use for the enhanced error info. - #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system - #todo - #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - - #todo - document unnamed leaders and unnamed values where -min and/or -max specified - #e.g punk::args::parse {} withdef {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} - #only |?-x?|string|... is shown in the output table. - #should be something like: - # |arg | - # |?-x? | - # |arg | - # |?arg...?| - # Where/how to specify counts? - #also.. - # use multi column for displaying limits on -multiple true args/switches e.g -multimin x -multimax y? - # - - - #limit colours to standard 16 so that themes can apply to help output - variable arg_error_isrunning - if {$arg_error_isrunning} { - error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" - } - - #set arg_error_CLR(testsinglecolour) [a+ brightred] - upvar ::punk::args::arg_error_CLR CLR - set forcereload 0 ;#no need for forcereload to be true for initial run - empty array will trigger initial load - if {[info exists CLR(testsinglecolour)]} { - set terminal_colour_is_on [expr {[string length [a+ yellow]]}] - set error_colour_is_on [expr {[string length $CLR(testsinglecolour)]}] - if {$terminal_colour_is_on ^ $error_colour_is_on} { - #results differ - set forcereload 1 - } - } - _argerror_load_colours $forcereload - - if {[llength $args] %2 != 0} { - set arg_error_isrunning 0 - error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" - } - - set arg_error_isrunning 1 - - set badarg "" - set parsedargs [dict create] ;#dict with keys: leaders,opts,values,received,solos,multis (as from punk::args::parse) - set goodargs [list] - #----------------------- - #todo!! make changeable from config file - #JJJ 2025-07-16 - set returntype table ;#table as string - #set returntype string - #---------------------- - set as_error 1 ;#usual case is to raise an error - set scheme error - set form 0 - dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -parsedargs -aserror -return -scheme -form} $k] - switch -- $fullk { - -badarg { - set badarg $v - } - -parsedargs { - #todo? - dict for {set setinfo} $v { - switch -- $set { - received { - foreach {r rpos} $setinfo { - if {$r ni $goodargs} { - lappend goodargs $r - } - } - } - } - } - set parsedargs $v - } - -aserror { - if {![string is boolean -strict $v]} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -aserror. Received '$v' expected a boolean" - } - set as_error $v - } - -scheme { - set scheme $v - } - -return { - if {[tcl::prefix::match -error "" {string table tableobject} $v] eq ""} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -return. Received '$v' expected one of: string table tableobject" - } - set returntype $v - } - -form { - set form $v - } - default { - set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -parsedargs -aserror -scheme -return -form" - } - } - } - #todo - scheme - use config and iterm toml definitions etc - switch -- $scheme { - "" - -nocolor - -nocolour { - set scheme nocolour - } - info - error {} - default { - set scheme na - } - } - set formnames [dict get $spec_dict form_names] - if {[string is integer -strict $form]} { - if {$form < 0 || $form > [llength $formnames]-1} { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - set selected_forms [list [lindex $formnames $form]] - } else { - if {$form eq "*"} { - set selected_forms $formnames - } else { - if {$form in $formnames} { - set selected_forms [list $form] - } else { - set arg_error_isrunning 0 - error "arg_error invalid value for option -form. Received '$v' Allowed values 0-[expr {[llength $formnames]-1}] or one of '$formnames'" - } - } - } - - - #hack some basics for now. - #for coloured schemes - use bold as well as brightcolour in case colour off. - - switch -- $scheme { - nocolour { - variable arg_error_CLR_nocolour - array set CLR [array get arg_error_CLR_nocolour] - } - info { - variable arg_error_CLR_info - array set CLR [array get arg_error_CLR_info] - } - error { - variable arg_error_CLR_error - array set CLR [array get arg_error_CLR_error] - } - na { - } - } - - - #set RST [a] - set RST "\x1b\[0m" - set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error - #e.g list_as_table - - # use basic colours here to support terminals without extended colours - #todo - add checks column (e.g -minsize -maxsize) - set errmsg $msg - if {![catch {package require textblock}]} { - set has_textblock 1 - } else { - set has_textblock 0 - #couldn't load textblock package - #just return the original errmsg without formatting - } - set use_table 0 - if {$has_textblock && $returntype in {table tableobject}} { - set use_table 1 - } - set errlines [list] ;#for non-textblock output - if {[catch { - if {$use_table} { - append errmsg \n - } else { - if {($returntype in {table tableobject}) && !$has_textblock} { - append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n - } else { - append errmsg \n - } - } - set cmdname [Dict_getdef $spec_dict cmd_info -name ""] - set cmdsummary [Dict_getdef $spec_dict cmd_info -summary ""] - set cmdhelp [Dict_getdef $spec_dict cmd_info -help ""] - - set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] - set docurl [Dict_getdef $spec_dict doc_info -url ""] - - #set argdisplay_header [Dict_getdef $spec_dict argdisplay_info -header ""] - #set argdisplay_body [Dict_getdef $spec_dict argdisplay_info -body ""] - #if {"$argdisplay_header$argdisplay_body" eq ""} { - # set is_custom_argdisplay 0 - #} else { - # set is_custom_argdisplay 1 - #} - - #temp - TODO - set argdisplay_header "" - set argdisplay_body "" - set is_custom_argdisplay 0 - - - set blank_header_col [list] - if {$cmdname ne ""} { - lappend blank_header_col "" - set cmdname_display $CLR(cmdname)$cmdname$RST - } else { - set cmdname_display "" - } - if {$cmdhelp ne ""} { - lappend blank_header_col "" - #set cmdhelp_display [a+ brightwhite]$cmdhelp[a] - #set cmdhelp_display [textblock::ansibase_lines $cmdhelp $CLR(linebase_header)] - set cmdhelp_display [punk::ansi::ansiwrap_raw $CLR(linebase_header) "" "" $cmdhelp] - } else { - set cmdhelp_display "" - } - if {$docurl ne ""} { - lappend blank_header_col "" - set docurl_display [a+ white]$docurl$RST - } else { - set docurl_display "" - } - #synopsis - set synopsis "# [Dict_getdef $spec_dict cmd_info -summary {}]\n" - set form_info [dict get $spec_dict form_info] - dict for {fid finfo} $form_info { - set form_synopsis [Dict_getdef $finfo -synopsis ""] - if {$form_synopsis eq ""} { - #todo - set form_synopsis [punk::args::synopsis -noheader -form $fid [dict get $spec_dict id]] - set ansifree_synopsis [punk::ansi::ansistripraw $form_synopsis] - if {[string length $ansifree_synopsis] > 90} { - # - set form_synopsis [punk::args::synopsis -noheader -return summary -form $fid [dict get $spec_dict id]] - } - #review - if {[string match (autodef)* $form_synopsis]} { - set form_synopsis [string range $form_synopsis 9 end] - } - } - if {$fid in $selected_forms} { - set form_synopsis [punk::ansi::a+ underline]$form_synopsis[punk::ansi::a+ nounderline] - } - append synopsis $form_synopsis \n - } - if {$synopsis ne ""} { - set synopsis [string trimright $synopsis \n] - lappend blank_header_col "" - } - - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - if {$use_table} { - set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col - - if {!$is_custom_argdisplay} { - lappend blank_header_col "" - #spanned columns in default argdisplay area - $t add_column -headers $blank_header_col ;#Default - $t add_column -headers $blank_header_col ;#Multi - $t add_column -headers $blank_header_col ;#Help - set arg_colspans {1 4 0 0 0} - } else { - if {$argdisplay_header ne ""} { - lappend blank_header_col "" - } - set arg_colspans {1 1} - } - } - set h 0 - if {$cmdname ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list COMMAND: $cmdname_display] - } else { - lappend errlines "COMMAND: $cmdname_display" - } - incr h - } - if {$cmdhelp ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Description: $cmdhelp_display] - } else { - lappend errlines "Description: $cmdhelp_display" - } - incr h - } - if {$docurl ne ""} { - if {![catch {package require punk::ansi}]} { - set docurl [punk::ansi::hyperlink $docurl] - } - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] - } else { - lappend errlines "$docname $docurl_display" - } - incr h - } - if {$synopsis ne ""} { - if {$use_table} { - $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] - } else { - #todo - lappend errlines "Synopsis:\n$synopsis" - } - incr h - } - - - if {$use_table} { - if {$is_custom_argdisplay} { - if {$argdisplay_header ne ""} { - $t configure_header $h -colspans {2 0} -values [list $argdisplay_header] - } - } else { - $t configure_header $h -values {Arg Type Default Multi Help} - } - } else { - lappend errlines " --ARGUMENTS-- " - } - - if {$is_custom_argdisplay} { - if {$use_table} { - #using overall container table - #header already added - #TODO - review textblock::table features - #we can't currently span columns within the table body. - #This feature could allow hidden data columns (and sort on hidden col?) - #potentially require coordination with header colspans? - $t add_row [list "" $argdisplay_body] - } else { - if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header - } - lappend errlines {*}$argdisplay_body - } - } else { - - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG $CLR(badarg) - set A_GOODARG $CLR(goodarg) - set A_GOODCHOICE $CLR(goodchoice) - set greencheck $CLR(check)\u2713$RST ;#green tick - set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply - if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { - #A_PREFIX can resolve to empty string if colour off - #we then want to display underline instead - set A_PREFIX [a+ underline] - #set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space (zwsp) - set A_PREFIXEND [a+ nounderline] - #review - zwsp problematic on older terminals that print it visibly - #- especially if they also lie about cursor position after it's emitted. - #so although the zwsp fixes the issue where the underline extends to rhs padding if all text was underlined, - #It's probably best fixed in the padding functionality. - } else { - set A_PREFIXEND $RST - } - - #TODO - foreach fid - set fid [lindex $selected_forms 0] - set form_dict [dict get $spec_dict FORMS $fid] - - set opt_names [list] - set opt_names_display [list] - set opt_names_hints [list] ;#comments in first column below name display. - set lookup_optset [dict create] - if {[llength [dict get $form_dict OPT_NAMES]]} { - set all_opts [list] - foreach optionset [dict get $form_dict OPT_NAMES] { - #e.g1 "-alias1|-realname" - #e.g2 "-f|--filename" (fossil longopt style) - #e.g3 "-f|--filename=" (gnu longopt style) - set optmembers [split $optionset |] - lappend all_opts {*}$optmembers - foreach o $optmembers { - dict set lookup_optset $o $optionset - #goodargs - } - } - set full_goodargs [list] - #goodargs may have simplified entries for received opts of form -alias1|-alias2|-realname - #map -realname to full argname - foreach g $goodargs { - if {[string match -* $g] && [dict exists $lookup_optset $g]} { - lappend full_goodargs [dict get $lookup_optset $g] - } else { - lappend full_goodargs $g - } - } - set goodargs $full_goodargs - if {![catch {package require punk::trie}]} { - #todo - reservelist for future options - or just to affect the prefix calculation - # (similar to -choiceprefixreservelist) - - set trie [punk::trie::trieclass new {*}$all_opts --] - set idents [dict get [$trie shortest_idents ""] scanned] - #todo - check opt_prefixdeny - - $trie destroy - foreach optset [dict get $form_dict OPT_NAMES] { - set arginfo [dict get $form_dict ARG_INFO $optset] - set parsekey [dict get $arginfo -parsekey] - set storageinfo "" - if {$parsekey ne "" && $parsekey ne $optset} { - set storageinfo "(stored as: $parsekey)" - } - if {[dict get $arginfo -prefix]} { - set opt_members [split $optset |] - set odisplay [list] - foreach opt $opt_members { - set id [dict get $idents $opt] - #REVIEW - if {$id eq $opt} { - set prefix $opt - set tail "" - } else { - set idlen [string length $id] - lassign [punk::lib::string_splitbefore $opt $idlen] prefix tail - } - lappend odisplay $A_PREFIX$prefix$A_PREFIXEND$tail - } - #lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - lappend opt_names_display [join $odisplay |] - } else { - lappend opt_names_display $optset - } - lappend opt_names_hints $storageinfo - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $optset - } - } else { - set opt_names [dict get $form_dict OPT_NAMES] - foreach optset [dict get $form_dict OPT_NAMES] { - set arginfo [dict get $form_dict ARG_INFO $optset] - set parsekey [dict get $arginfo -parsekey] - set storageinfo "" - if {$parsekey ne "" && $parsekey ne $optset} { - set storageinfo "(stored as: $parsekey)" - } - lappend opt_names_display $optset - lappend opt_names_hints $storageinfo - } - #set opt_names_display $opt_names - } - } - set leading_val_names [dict get $form_dict LEADER_NAMES] - set trailing_val_names [dict get $form_dict VAL_NAMES] - - #dict for {argname info} [tcl::dict::get $form_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set leading_val_names_hints {} - set trailing_val_names_display $trailing_val_names - set trailing_val_names_hints {} - #puts "--> parsedargs: $parsedargs" - set parsed_leaders [Dict_getdef $parsedargs leaders {}] - set parsed_opts [Dict_getdef $parsedargs opts {}] - set parsed_values [Dict_getdef $parsedargs values {}] - - #display options first then values - foreach argumentclassinfo [list [list leaders $leading_val_names_display $leading_val_names_hints $leading_val_names $parsed_leaders] [list opts $opt_names_display $opt_names_hints $opt_names $parsed_opts] [list values $trailing_val_names_display $trailing_val_names_hints $trailing_val_names $parsed_values]] { - lassign $argumentclassinfo argumentclass argnames_display argnames_hints argnames parsedvalues - set lastgroup "" - set lastgroup_parsekey "" - foreach argshow $argnames_display hint $argnames_hints arg $argnames { - set arginfo [dict get $form_dict ARG_INFO $arg] - - if {$argumentclass eq "opts"} { - set thisgroup [dict get $arginfo -group] - if {$thisgroup ne $lastgroup} { - if {[dict exists $form_dict OPT_GROUPS $thisgroup -parsekey]} { - set thisgroup_parsekey [dict get $form_dict OPT_GROUPS $thisgroup -parsekey] - } else { - set thisgroup_parsekey "" - } - - #footer/line? - if {$use_table} { - $t add_row [list " " "" "" "" ""] - } else { - lappend errlines " " - } - - if {$thisgroup eq ""} { - } else { - #SHOW group 'header' (not really a table header - just another row) - set help "" - if {[dict exists $form_dict OPT_GROUPS $thisgroup -help]} { - set help [dict get $form_dict OPT_GROUPS $thisgroup -help] - } - if {$thisgroup_parsekey eq ""} { - set groupinfo "(documentation group)" - } else { - set groupinfo "(common flag group)\nkey:$thisgroup_parsekey" - } - if {$use_table} { - $t add_row [list " $thisgroup" $groupinfo "" "" $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } elseif {$arg in $goodargs || $thisgroup_parsekey in $goodargs} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - #set arghelp "[a+ bold] $thisgroup$RST $groupinfo" - set arghelp [textblock::join -- "[a+ bold] $thisgroup$RST" " " $groupinfo] - append arghelp \n - if {$arg eq $badarg} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] - } elseif {$arg in $goodargs} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] - } - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - set lastgroup $thisgroup - set lastgroup_parsekey $thisgroup_parsekey - } - if {[dict exists $arginfo -parsekey]} { - set mypkey [dict get $arginfo -parsekey] - if {$mypkey eq "$lastgroup_parsekey" || $mypkey eq [string trimright [lindex [split $arg |] end] =]} { - set hint "" - } - } - } - - if {[dict exists $arginfo -default]} { - #default isn't necessarily of same type as -type required for validation - #Guessing at the type from the data is likely to be unsatisfactory. - - set defaultdisplaytype [Dict_getdef $arginfo -defaultdisplaytype string] - switch -- $defaultdisplaytype { - dict { - #single level - set rawdefault [dict get $arginfo -default] - set default "{\n" - dict for {k v} $rawdefault { - append default " \"$k\" \"$v\"\n" - } - append default "}" - } - list { - set default "{\n" - foreach v $rawdefault { - append default " \"$v\"\n" - } - append default "}" - } - default { - #set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" - set default "'[dict get $arginfo -default]'" - } - } - } else { - set default "" - } - set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] - set choices [Dict_getdef $arginfo -choices {}] - set choicegroups [Dict_getdef $arginfo -choicegroups {}] - set choicemultiple [dict get $arginfo -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] - set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] - set choiceprefixreservelist [Dict_getdef $arginfo -choiceprefixreservelist {}] ;#names used to calc prefix - but not available as actual choice. - if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - set is_multiple 1 - } else { - set multiple "" - set is_multiple 0 - } - if {[dict exists $choicegroups ""]} { - dict lappend choicegroups "" {*}$choices - } else { - set choicegroups [dict merge [dict create "" $choices] $choicegroups] - } - #review - does choiceprefixdenylist need to be added? - dict for {groupname clist} $choicegroups { - lappend allchoices_originalcase {*}$clist - } - set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] - - if {$has_choices} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" - set allchoices_prefixcalc [list {*}[string tolower $allchoices_originalcase] {*}$choiceprefixreservelist] - } else { - set casemsg " (case sensitive)" - set allchoices_prefixcalc [list {*}$allchoices_originalcase {*}$choiceprefixreservelist] - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set choiceinfodict [Dict_getdef $arginfo -choiceinfo {}] - set formattedchoices [dict create] ;#use dict rather than array to preserve order - append help "Choices$prefixmsg$casemsg" - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - if {$choicemultiple_max == -1} { - append help \n " The value can be a list of $choicemultiple_min or more of these choices" - } else { - if {$choicemultiple_min eq $choicemultiple_max} { - append help \n " The value must be a list of $choicemultiple_min of these choices" - } else { - append help \n " The value can be a list of $choicemultiple_min to $choicemultiple_max of these choices" - } - } - } - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - #set formattedchoices [dict get $arginfo -choices] - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_prefixcalc] - set idents [dict get [$trie shortest_idents ""] scanned] - if {[dict get $arginfo -nocase]} { - #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents - foreach ch $allchoices_originalcase { - if {![dict exists $idents $ch]} { - #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict - dict set actual_idents $ch [dict get $idents [string tolower $ch]] - } - } - set idents $actual_idents - #puts "-----" - #puts "idents $idents" - } - - $trie destroy - dict for {groupname clist} $choicegroups { - foreach c $clist { - if {$c in $choiceprefixdenylist} { - set shortestid $c - } else { - set shortestid [dict get $idents $c] - } - lassign [punk::lib::string_splitbefore $c [string length $shortestid]] prefix tail - #if {$shortestid eq $c} { - # set prefix $c - # set tail "" - #} else { - # set idlen [string length $shortestid] - # set prefix [string range $c 0 $idlen-1] - # set tail [string range $c $idlen end] - #} - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set mk " [join $markers {}]" - } else { - set mk "" - } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]$mk" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - #puts "-- parsed:$parsedvalues arg:$arg c:$c" - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } errM]} { - #this failure can happen if -nocase is true and there are ambiguous entries - #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c [join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } else { - #set formattedchoices $choicegroups - dict for {groupname clist} $choicegroups { - foreach c $clist { - set markers [punk::args::lib::choiceinfo_marks $c $choiceinfodict] - if {[llength $markers]} { - set cdisplay "$c[join $markers {}]" - } else { - set cdisplay $c - } - if {[dict exists $parsedvalues $arg] && [dict get $parsedvalues $arg] eq $c} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } elseif {[dict exists $parsedvalues $arg] && $is_multiple && $c in [dict get $parsedvalues $arg]} { - dict lappend formattedchoices $groupname [punk::ansi::ansiwrap reverse $cdisplay] - } else { - dict lappend formattedchoices $groupname $cdisplay - } - } - } - } - - } - } - set choicetable_objects [list] - set choicetable_footers [dict create] - dict for {groupname formatted} $formattedchoices { - set numcols $choicecolumns ;#todo - dynamic? - if {[llength $formatted] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formatted] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - #TODO -title directly in list_as_table - set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] - lappend choicetable_objects $choicetableobj - $choicetableobj configure -title $CLR(groupname)$groupname - #append help \n[textblock::join -- " " [$choicetableobj print]] - } else { - if {$groupname ne ""} { - append help \n \n "$CLR(groupname)Group: $groupname$RST" - } else { - append help \n - } - append help \n [join $formatted \n] - } - } else { - #we were given an empty set of choices. - #probably an error in the definition - but could happen if dynamically generated. - #(e.g ensemble where unknown mechanism is used for subcommands?) - #better to just display that there were none rather than totally break the usage output. - if {$usetable} { - #these will be displayed after all table entries - if {$groupname eq ""} { - dict set choicetable_footers "" " $CLR(errormsg)(no choices defined for main group)$RST" - } else { - dict set choicetable_footers $groupname " $CLR(errormsg)(no choices defined for group $groupname)$RST" - } - } else { - if {$groupname eq ""} { - append help \n " " $CLR(errormsg)(no choices defined)$RST - } else { - append help \n " " $CLR(errormsg)(no choices defined for group $groupname)$RST - } - } - } - } - set twidths_by_colcount [dict create] ;#to set all subtables with same colcount to same width - foreach obj $choicetable_objects { - dict lappend twidths_by_colcount [$obj column_count] [$obj width] - } - foreach obj $choicetable_objects { - set cols [$obj column_count] - set widths [dict get $twidths_by_colcount $cols] - set max [tcl::mathfunc::max {*}$widths] - $obj configure -minwidth $max ;#expand smaller ones - set i 0 - while {$i < $cols} { - #keep text aligned left on expanded tables - $obj configure_column $i -blockalign left - incr i - } - append help \n[textblock::join -- " " [$obj print]] - #------------- - #todo - tests - #see special case double reset at end of content in textblock class table get_column_by_index - #bug fixed - needed to ensure last two resets were actually concurrent and at end. - #append help "\nbase[a+ green]ab\nc[a]base" ;#ok - #vs - #append help "\nbase[a+ green]a[a]b\nc[a]base" ;#not ok - #------------- - - #set ansititle [dict get [$obj configure -title] value] - $obj destroy - } - if {[dict size $choicetable_footers]} { - foreach groupname [dict keys $formattedchoices] { - if {[dict exists $choicetable_footers $groupname]} { - append help \n [dict get $choicetable_footers $groupname] - } - } - } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - #when -choicemultiple - the -type refers to each selection - if {[dict get $arginfo -type] eq "string"} { - append help "\n (values not in defined choices are allowed)" - } else { - append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" - } - } - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - if {$is_multiple} { - set argshow "?${argshow}...?" - } else { - set argshow "?${argshow}?" - } - } else { - if {$is_multiple} { - set argshow "${argshow}..." - } - } - set typeshow [dict get $arginfo -type] - if {$typeshow eq "none"} { - set typeshow "$typeshow $soloflag" - } - if {[dict exists $arginfo -minsize]} { - append typeshow \n "-minsize [dict get $arginfo -minsize]" - } - if {[dict exists $arginfo -maxsize]} { - append typeshow \n "-maxsize [dict get $arginfo -maxsize]" - } - if {[dict exists $arginfo -typeranges]} { - set ranges [dict get $arginfo -typeranges] - if {[llength $ranges] == 1} { - append typeshow \n "-range [lindex [dict get $arginfo -typeranges] 0]" - } else { - append typeshow \n "-ranges" - foreach r $ranges { - append typeshow " {$r}" - } - } - } - - if {$use_table} { - if {$hint ne ""} { - set col1 $argshow\n$hint - } else { - set col1 $argshow - } - $t add_row [list $col1 $typeshow $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } elseif {$arg in $goodargs} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_GOODARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - set linetail " TYPE:$typeshow DEFAULT:$default MULTI:$multiple" - if {$hint ne ""} { - set arghelp [textblock::join -- "[a+ bold]$argshow\n$hint$RST" $linetail] - } else { - set arghelp "[a+ bold]$argshow$RST $linetail" - } - append arghelp \n - if {$arg eq $badarg} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_BADARG $arghelp] - } elseif {$arg in $goodargs} { - set arghelp [punk::ansi::ansiwrap -rawansi $A_GOODARG $arghelp] - } - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - - # ------------------------------------------------------------------------------------------------------- - # if the argument class can accept unnamed arguments (or if opts accepts unspecified flags) - display an indication - # ------------------------------------------------------------------------------------------------------- - switch -- $argumentclass { - leaders - values { - if {$argumentclass eq "leaders"} { - set class_unnamed LEADER_UNNAMED - set class_max LEADER_MAX - set class_required LEADER_REQUIRED - set class_directive_defaults LEADERSPEC_DEFAULTS - } else { - set class_unnamed VAL_UNNAMED - set class_max VAL_MAX - set class_required VAL_REQUIRED - set class_directive_defaults VALSPEC_DEFAULTS - } - if {[dict get $form_dict $class_unnamed]} { - set valmax [dict get $form_dict $class_max] - #set valmin [dict get $form_dict VAL_MIN] - if {$valmax eq ""} { - set valmax -1 - } - if {$valmax == -1} { - set possible_unnamed -1 - } else { - set possible_unnamed [expr {$valmax - [llength [dict get $form_dict $class_required]]}] - if {$possible_unnamed < 0} { - set possible_unnamed 0 - } - } - if {$possible_unnamed == -1 || $possible_unnamed > 0} { - #Note 'multiple' is always empty here as each unnamed is assigned to its own positional index - if {$possible_unnamed == 1} { - set argshow ?? - } else { - set argshow ?...? - } - set tp [dict get $form_dict $class_directive_defaults -type] - if {[dict exists $form_dict $class_directive_defaults -default]} { - set default [dict get $form_dict $class_directive_defaults -default] - } else { - set default "" - } - if {$use_table} { - $t add_row [list "$argshow" $tp $default "" ""] - } else { - set arghelp "[a+ bold]$argshow$RST TYPE:$tp DEFAULT:$default\n" - lappend errlines $arghelp - } - } - } - } - opts { - #display row to indicate if -any|-arbitrary true - - #review OPTSPEC_DEFAULTS -multiple ? - if {[dict get $form_dict OPT_ANY]} { - set argshow "?...?" - set tp [dict get $form_dict OPTSPEC_DEFAULTS -type] - if {[dict exists $form_dict OPTSPEC_DEFAULTS -default]} { - set default [dict get $form_dict OPTSPEC_DEFAULTS -default] - } else { - set default "" - } - if {$use_table} { - $t add_row [list "$argshow" $tp $default "" ""] - } else { - set arghelp "[a+ bold]$argshow$RST TYPE:$tp DEFAULT:$default\n" - lappend errlines $arghelp - } - } - } - } - - } ;#end foreach argumentclass - } ;#end is_custom_argdisplay - - if {$use_table} { - $t configure -show_hseps 0\ - -show_header 1\ - -ansibase_body $CLR(ansibase_body)\ - -ansibase_header $CLR(ansibase_header)\ - -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) - - $t configure -maxwidth 80 ;#review - if {$returntype ne "tableobject"} { - append errmsg [$t print] - #returntype of table means just the text of the table - $t destroy - } - } else { - append errmsg [join $errlines \n] - } - } errM]} { - append errmsg \n - append errmsg "(additional error in punk::args::arg_error when attempting to display usage)" \n - append errmsg "$errM" \n - append errmsg "$::errorInfo" - catch {$t destroy} - - } - set arg_error_isrunning 0 - if {$use_table} { - #assert returntype is one of table, tableobject - set result $errmsg ;#default if for some reason table couldn't be used - if {$returntype eq "tableobject"} { - if {[info object isa object $t]} { - set result $t - } - } else { - #put original error at bottom of table too - append result \n $msg - } - } else { - set result $errmsg - append result \n $msg - } - if {$as_error} { - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. - #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) - uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $result] - } else { - return $result - } - } - - - lappend PUNKARGS [list { - @dynamic - @id -id ::punk::args::usage - @cmd -name punk::args::usage -help\ - "Return usage information for a command identified by an id. - - This will only work for commands where a punk::args definition exists - for the command and an id has been defined for it. The id for custom - help for a command should match the fully qualified name of the command. - - Many commands (such as ensembles and oo objects) may have argument - documentation generated dynamically and may not yet have an id. - IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. - - Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. - " - -return -default table -choices {string table tableobject} - }\ - {${[punk::args::resolved_def -types opts -override {-scheme {-default info}} ::punk::args::arg_error -scheme]}}\ - {${[punk::args::resolved_def -types opts ::punk::args::resolved_def -form]}}\ - { - - @values -min 0 -max 1 - id -help\ - "Exact id. - Will usually match the command name" - }] - proc usage {args} { - #lassign [dict values [punk::args::get_by_id ::punk::args::usage $args]] leaders opts values received - lassign [dict values [punk::args::parse $args withid ::punk::args::usage]] leaders opts values received - set id [dict get $values id] - set real_id [real_id $id] - if {$real_id eq ""} { - error "punk::args::usage - no such id: $id" - } - #-scheme punk_info ?? - arg_error "" [punk::args::get_spec $real_id] {*}$opts -aserror 0 - } - - lappend PUNKARGS [list { - @id -id ::punk::args::get_by_id - @cmd -name punk::args::get_by_id - @values -min 1 - id - arglist -type list -help\ - "list containing arguments to be parsed as per the - argument specification identified by the supplied id." - }] - - - #deprecate? - proc get_by_id {id arglist} { - set definitionlist [punk::args::raw_def $id] - if {[llength $definitionlist] == 0} { - error "punk::args::get_by_id - no such id: $id" - } - #uplevel 1 [list ::punk::args::get_dict {*}$definitionlist $arglist] - tailcall ::punk::args::get_dict $definitionlist $arglist - } - - #consider - - #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id - #parse ?-flag val?... -- $arglist withdef $def ?$def?... - - #an experiment.. ideally we'd like arglist at the end? - #parse_withid ?-flag val?.. $id $arglist - #parse_withdef ?-flag val?.. -- $def ?$def?... $arglist ;#error prone syntax? - #no possible equivalent for parse_withdef ??? - - lappend PUNKARGS [list { - @id -id ::punk::args::parse - @cmd -name punk::args::parse -help\ - "parse and validate command arguments based on a definition. - - In the 'withid' form the definition is a pre-existing record that has been - created with ::punk::args::define, or indirectly by adding a definition to - the PUNKARGS variable in a namespace which is then registered in - punk::args::register::NAMESPACES, or by a previous call to punk::parse - using 'withdef' and a definition block containing an @id -id directive. - - In the 'withdef' form - the definition is created on the first call and - cached thereafter, if the id didn't already exist. - - form1: parse $arglist ?-flag val?... withid $id - form2: parse $arglist ?-flag val?... withdef $def ?$def? - see punk::args::define - - Returns a dict of information regarding the parsed arguments - example of basic usage for single option only: - punk::args::define { - @id -id ::myns::myfunc - @cmd -name myns::myfunc - @leaders -min 0 -max 0 - @opts - -configfile -type existingfile - #type none makes it a solo flag - -verbose -type none - @values -min 0 -max 0 - } - proc myfunc {args} { - set argd [punk::args::parse $args withid ::myns::myfunc] - lassign [dict values $argd] leaders opts values received solos - if {[dict exists $received] -configfile} { - puts \"have option for existing file [dict get $opts -configfile]\" - } - } - The leaders, opts, values keys in the parse result dict are proper dicts. - The received key is dict-like but can have repeated keys for arguments than can - accept multiples. The value for each received element is the ordinal position. - The solos key refers to a list of solo flags received (those specified with - -type none). This is generally only useful to assist in passing arguments on - to another procedure which also requires solos, because the opts dict contains - solo flags with a 1 value or a list of 1's if it was a solo with -multiple true - specified. - " - @form -form {withid withdef} - @leaders -min 1 -max 1 - arglist -type list -optional 0 -help\ - "Arguments to parse - supplied as a single list" - - @opts - -form -type list -default * -help\ - "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a - command can take - usually described in 'synopsis' - entries." - #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance - #todo - configurable per interp/namespace - -errorstyle -type string -default enhanced -choices {enhanced standard basic minimal} - - @values -min 2 - - @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" - @values -max 2 - withid -type literal -help\ - "The literal value 'withid'" - id -type string -help\ - "id of punk::args definition for a command" - - - @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" - withdef -type literal -help\ - "The literal value 'withdef'" - - #todo - make -dynamic obsolete - use @dynamic directive instead - def -type string -multiple 1 -optional 0 -help\ - "Each remaining argument is a block of text - defining argument definitions. - As a special case, -dynamic may be - specified as the 1st 2 arguments. These are - treated as an indicator to punk::args about - how to process the definition." - - }] - proc parse {args} { - #puts "punk::args::parse --> '$args'" - set tailtype "" ;#withid|withdef - if {[llength $args] < 3} { - #error "punk::args::parse - invalid call. < 3 args" - punk::args::parse $args withid ::punk::args::parse - } - set opts_and_vals $args - set parseargs [lpop opts_and_vals 0] - - set opts [list] - set values [list] - for {set i 0} {$i < [llength $opts_and_vals]} {incr i} { - if {[string match -* [lindex $opts_and_vals $i]]} { - if {[catch { - lappend opts [lpop opts_and_vals 0] [lpop opts_and_vals 0] - }]} { - #unhappy path - not enough options - #review - which form of punk::args::parse? - #we expect this to always raise error - review - set result [punk::args::parse $args withid ::punk::args::parse] - puts stderr "punk::args::parse unexpected result $result" - return ;#failsafe - } - incr i -1 - #lappend opts $a [lindex $opts_and_vals $i] - } else { - break - } - } - #set values [lrange $opts_and_vals $i end] - set values $opts_and_vals - #puts "---values: $values" - set tailtype [lindex $values 0] - set tailargs [lrange $values 1 end] - - - #set split [lsearch -exact $tailargs withid] - #if {$split < 0} { - # set split [lsearch -exact $tailargs withdef] - # if {$split < 0} { - # #punk::args::usage arg_error? - # #error "punk::args::parse - invalid call. keyword withid|withdef required" - # punk::args::parse $args withid ::punk::args::parse - # } else { - # set tailtype withdef - #} - #} else { - # set tailtype withid - #} - #set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. - - - #if {[llength $opts] % 2} { - #error "punk::args::parse Even number of -flag val pairs required after arglist" - #} - - #Default the -errorstyle to standard - # (slow on unhappy path - but probably clearest for playing with new APIs interactively) - # - application devs should distribute a config file with an errorstyle override if desired. - # - devs who prefer a different default for interactive use should create a config for it. (todo) - set defaultopts [dict create\ - -form {*}\ - -errorstyle standard\ - ] - - #todo - load override_errorstyle from configuration - #dict set defaultopts -errorstyle $ - #puts "def: $defaultopts opts: $opts" - set opts [dict merge $defaultopts $opts] - dict for {k v} $opts { - switch -- $k { - -form - -errorstyle { - } - default { - #punk::args::usage $args withid ::punk::args::parse ?? - #error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" - punk::args::parse $args withid ::punk::args::parse - } - } - } - switch -- $tailtype { - withid { - if {[llength $tailargs] != 1} { - #error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - punk::args::parse $args withid ::punk::args::parse - } - set id [lindex $tailargs 0] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - #puts stdout "punk::args::parse '$parseargs' withid $id, options: $opts" - set deflist [raw_def $id] - if {[llength $deflist] == 0} { - error "punk::args::parse - no such id: $id" - } - } - withdef { - set deflist $tailargs - if {[llength $deflist] < 1} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - #puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts" - #puts stdout "punk::args::parse '$parseargs' with [llength $deflist] definition blocks, options: $opts" - } - default { - error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'" - } - } - try { - #puts stdout "parse --> get_dict $parseargs -form [dict get $opts -form]" - set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] - } trap {PUNKARGS VALIDATION} {msg erroropts} { - set opt_errorstyle [dict get $opts -errorstyle] - - #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - - - set ecode [dict get $erroropts -errorcode] - #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... - set msg [string map [list %caller% [Get_caller]] $msg] - switch -- $opt_errorstyle { - minimal { - return -options [list -code error -errorcode $ecode] $msg - } - basic { - #No table layout - unix manpage style - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - standard { - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - } - return -options [list -code error -errorcode $ecode] $msg - } - enhanced { - set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) - set customdict [lrange $ecode 3 end] - set argspecs [Dict_getdef $customdict -argspecs ""] - set badarg [Dict_getdef $customdict -badarg ""] - set ecode_summary [lrange $ecode 0 2] - if {$badarg ne ""} { - lappend ecode_summary -badarg $badarg - } - catch {package require punk::lib} - if {[package provide punk::lib] ne ""} { - append msg \n [punk::lib::showdict -roottype list $estack */*] - } - if {$argspecs ne ""} { - set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } else { - #why? todo? - append msg \n "(enhanced error information unavailable)" - append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg - } - } - debug { - puts stderr "errorstyle debug not implemented" - return -options [list -code error -errorcode $ecode] $msg - } - default { - puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" - return -options [list -code error -errorcode $ecode] $msg - } - } - } trap {PUNKARGS} {msg erropts} { - append msg \n "Unexpected PUNKARGS error" - return -options [list -code error -errorcode $ecode] $msg - } trap {} {msg erroropts} { - #review - #quote from DKF: The reason for using return -code error vs error or throw depends on where the error is. If the problem is in your code, use error or throw. - #If the problem is in your caller (e.g., because they gave you bad arguments) then use return -code error. Simple. - throw [dict get $erroropts -errorcode] [dict get $erroropts -errorinfo] - } - return $result - } - proc parseXXX {args} { - #no solo flags allowed for parse function itself. (ok for arglist being parsed) - set opts [dict create] ;#repeated flags will override earlier. That's ok here. - set arglist {} - set got_arglist 0 - set tailtype "" ;#withid|withdef - set id "" - for {set i 0} {$i < [llength $args]} {incr i} { - set a [lindex $args $i] - if {[string match -* $a]} { - dict set opts $a [lindex $args $i+1] - incr i - } else { - set arglist $a - set got_arglist 1 - set tailtype [lindex $args $i+1] - if {$tailtype eq "withid"} { - if {[llength $args] != $i+3} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $args $i+2] - break - } elseif {$tailtype eq "withdef"} { - if {[llength $args] < $i+3} { - error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'" - } - set deflist [lrange $args $i+2 end] - break - } else { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - } - if {!$got_arglist} { - error "punk::args::parse - invalid call. Argument list not found: usage parse ?-flag val?... arglist withid|withdef ..." - } - #assert tailtype eq withid|withdef - if {$tailtype eq "withid"} { - #assert $id was provided - return "parse [llength $arglist] args withid $id, options:$opts" - } else { - #assert llength deflist >=1 - return "parse [llength $arglist] with [llength $deflist] definition blocks, options:$opts" - } - #TODO - } - - - #return number of values we can assign to cater for variable length clauses such as {"elseif" expr "?then?" body} - #review - efficiency? each time we call this - we are looking ahead at the same info - proc _get_dict_can_assign_value {idx values nameidx names namesreceived formdict} { - set ARG_INFO [dict get $formdict ARG_INFO] - set all_remaining [lrange $values $idx end] - set thisname [lindex $names $nameidx] - set thistype [dict get $ARG_INFO $thisname -type] - set tailnames [lrange $names $nameidx+1 end] - - #todo - work backwards with any (optional or not) literals at tail that match our values - and remove from assignability. - set ridx 0 - foreach clausename [lreverse $tailnames] { - #puts "=============== clausename:$clausename all_remaining: $all_remaining" - set typelist [dict get $ARG_INFO $clausename -type] - if {[lsearch $typelist literal*] == -1} { - break - } - set max_clause_length [llength $typelist] - if {$max_clause_length == 1} { - #basic case - set alloc_ok 0 - #set v [lindex $values end-$ridx] - set v [lindex $all_remaining end] - set tp [lindex $typelist 0] - # ----------------- - set tp [string trim $tp ?] ;#shouldn't be necessary - #review - ignore ?literal? and ?literal(xxx)? when clause-length == 1? (should raise error during definition instead? - #we shouldn't have an optional clause member if there is only one member - the whole argument should be marked -optional true instead. - # ----------------- - - #todo - support complex type members such as -type {{literal a|b} int OR} - #for now - require llength 1 - simple type such as -type {literal(ab)|int} - if {[llength $tp] !=1} { - error "_get_dict_can_assign_value: complex -type not yet supported (tp:'$tp')" - } - - #foreach tp_alternative [split $tp |] {} - foreach tp_alternative [_split_type_expression $tp] { - switch -exact -- [lindex $tp_alternative 0] { - literal { - set litinfo [string range $tp 7 end] ;#get bracketed part if of form literal(xxx) - set match [lindex $tp_alternative 1] - if {$v eq $match} { - set alloc_ok 1 - ledit all_remaining end end - if {![dict get $ARG_INFO $clausename -multiple]} { - ledit tailnames end end - } - #the type (or one of the possible type alternates) matched a literal - break - } - } - stringstartswith { - set pfx [lindex $tp_alternative 1] - if {[string match "$pfx*" $v} { - set alloc_ok 1 - set alloc_ok 1 - ledit all_remaining end end - if {![dict get $ARG_INFO $clausename -multiple]} { - ledit tailnames end end - } - break - } - - } - stringendswith { - set sfx [lindex $tp_alternative 1] - if {[string match "*$sfx" $v} { - set alloc_ok 1 - set alloc_ok 1 - ledit all_remaining end end - if {![dict get $ARG_INFO $clausename -multiple]} { - ledit tailnames end end - } - break - } - - } - default {} - } - } - if {!$alloc_ok} { - if {![dict get $ARG_INFO $clausename -optional]} { - break - } - } - - } else { - #todo - use _split_type_expression - - - #review - we assume here that we don't have a set of clause-members where all are marked optional (?membertype?) - #This is better caught during definition. - #e.g rn = {elseif expr (?then?) body} typelist = {literal expr ?literal? script} - #set cvals [lrange $values end-$ridx end-[expr {$ridx + $max_clause_length-1}]] - set cvals [lrange $values end-[expr {$ridx + $max_clause_length-1}] end-$ridx] - set rcvals [lreverse $cvals] - set alloc_count 0 - #clause name may have more entries than types - extras at beginning are ignored - set rtypelist [lreverse $typelist] - set alloc_ok 0 - set reverse_type_index 0 - #todo handle type-alternates - # for example: -type {string literal(x)|literal(y)} - foreach tp $rtypelist { - #set rv [lindex $rcvals end-$alloc_count] - set rv [lindex $all_remaining end-$alloc_count] - if {[string match {\?*\?} $tp]} { - set clause_member_optional 1 - } else { - set clause_member_optional 0 - } - set tp [string trim $tp ?] - switch -glob $tp { - literal* { - set litinfo [string range $tp 7 end] - set match [string range $litinfo 1 end-1] - #todo -literalprefix - if {$rv eq $match} { - set alloc_ok 1 ;#we need at least one literal-match to set alloc_ok - incr alloc_count - } else { - if {$clause_member_optional} { - # - } else { - set alloc_ok 0 - break - } - } - } - "stringstartswith(*" { - set pfx [string range $tp 17 end-1] - if {[string match "$pfx*" $tp]} { - set alloc_ok 1 - incr alloc_count - } else { - if {!$clause_member_optional} { - set alloc_ok 0 - break - } - } - } - default { - if {$clause_member_optional} { - #review - optional non-literal makes things harder.. - #we don't want to do full type checking here - but we now risk allocating an item that should actually - #be allocated to the previous value - # todo - lsearch to next literal or non-optional? - set prev_type [lindex $rtypelist $reverse_type_index+1] - if {[string match literal* $prev_type]} { - set litinfo [string range $prev_type 7 end] - #todo -literalprefix - if {[string match (*) $litinfo]} { - set match [string range $litinfo 1 end-1] - } else { - set match [lindex $rclausename $reverse_type_index+1] - } - if {$rv ne $match} { - #current val doesn't match previous type - allocate here - incr alloc_count - } - } else { - #no literal to anchor against.. - incr alloc_count - } - } else { - #allocate regardless of type - we're only matching on arity and literal positioning here. - #leave final type-checking for later. - incr alloc_count - } - } - } - incr reverse_type_index - } - if {$alloc_ok && $alloc_count > 0} { - #set n [expr {$alloc_count -1}] - #set all_remaining [lrange $all_remaining end-$n end] - set all_remaining [lrange $all_remaining 0 end-$alloc_count] - #don't lpop if -multiple true - if {![dict get $ARG_INFO $clausename -multiple]} { - #lpop tailnames - ledit tailnames end end - } - } else { - break - } - } - incr ridx - } - set num_remaining [llength $all_remaining] - - if {[dict get $ARG_INFO $thisname -optional] || ([dict get $ARG_INFO $thisname -multiple] && $thisname in $namesreceived)} { - #todo - check -multiple for required min/max (not implemented: make -multiple accept ?) - #thisname already satisfied, or not required - set tail_needs 0 - foreach t $tailnames { - if {![dict get $ARG_INFO $t -optional]} { - set min_clause_length [llength [lsearch -all -not [dict get $ARG_INFO $t -type] {\?*\?}]] - incr tail_needs $min_clause_length - } - } - set all_remaining [lrange $all_remaining 0 end-$tail_needs] - } - - #thistype - set alloc_ok 1 ;#default assumption only - set alloc_count 0 - set resultlist [list] - set n [expr {[llength $thistype]-1}] - set tpidx 0 - set newtypelist $thistype - set has_choices [expr {[tcl::dict::exists $ARG_INFO $thisname -choices] || [tcl::dict::exists $ARG_INFO $thisname -choicegroups]}] - foreach tp $thistype { - #usual case is a single tp (basic length-1 clause) - but tp may commonly have alternates eg int|literal(xxx) - set v [lindex $all_remaining $alloc_count] - if {[string match {\?*\?} $tp]} { - set clause_member_optional 1 - } else { - set clause_member_optional 0 - } - set tp [string trim $tp ?] - - set member_satisfied 0 - if {$has_choices} { - #each tp in the clause is just for validating a value outside the choice-list when -choicerestricted 0 - set member_satisfied 1 - } - - - if {!$member_satisfied} { - #----------------------------------------------------------------------------------- - #first build category lists of any literal,literalprefix,stringstartwith,other - # - set ctg_literals [list] - set ctg_literalprefixes [list] - set ctg_stringstartswith [list] - set ctg_stringendswith [list] - set ctg_other [list] - #foreach tp_alternative [split $tp |] {} - foreach tp_alternative [_split_type_expression $tp] { - #JJJJ - lassign $tp_alternative t textra - switch -exact -- $t { - literal { - lappend ctg_literals $textra - } - literalprefix { - lappend ctg_literalprefixes $textra - } - stringstartswith { - lappend ctg_stringstartswith $textra - } - stringendswith { - lappend ctg_stringendswith $textra - } - default { - lappend ctg_other $tp_alternative - } - } - } - #----------------------------------------------------------------------------------- - if {[llength $ctg_other] > 0} { - #presence of any ordinary type as one of the alternates - means we consider it a match if certain basic types align - #we don't do full validation here -leave main validation for later (review) - foreach tp_alternative $ctg_other { - switch -exact -- $tp_alternative { - int { - if {[string is integer -strict $v]} { - set member_satisfied 1 - break - } - } - double { - if {[string is double -strict $v]} { - set member_satisfied 1 - break - } - } - bool { - if {[string is boolean -strict $v]} { - set member_satisfied 1 - break - } - } - number { - if {[string is integer -strict $v] || [string is double -strict $v]} { - set member_satisfied 1 - break - } - } - dict { - if {[punk::args::lib::string_is_dict $v]} { - set member_satisfied 1 - break - } - } - default { - #REVIEW!!! - #can get infinite loop in get_dict if not satisfied - unstoppable until memory exhausted. - #todo - catch/detect in caller - set member_satisfied 1 - break - } - } - } - } - } - - if {!$member_satisfied && ([llength $ctg_literals] || [llength $ctg_literalprefixes])} { - if {$v in $ctg_literals} { - set member_satisfied 1 - lset newtypelist $tpidx validated-$tp - } else { - #ctg_literals is included in the prefix-calc - but a shortened version of an entry in literals is not allowed - #(exact match would have been caught in other branch of this if) - #review - how does ctg_stringstartswith affect prefix calc for literals? - set full_v [tcl::prefix::match -error "" [list {*}$ctg_literals {*}$ctg_literalprefixes] $v] - if {$full_v ne "" && $full_v ni $ctg_literals} { - #matched prefix must be for one of the entries in ctg_literalprefixes - valid - set member_satisfied 1 - set v $full_v ;#map prefix given as arg to the full literalprefix value - lset newtypelist $tpidx validated-$tp - } - } - } - if {!$member_satisfied && [llength $ctg_stringstartswith]} { - foreach pfx $ctg_stringstartswith { - if {[string match "$pfx*" $v]} { - set member_satisfied 1 - lset newtypelist $tpidx validated-$tp - #review. consider multi-word typespec with RPN? - # {*}$tp_alternative validated - break - } - } - } - if {!$member_satisfied && [llength $ctg_stringendswith]} { - foreach pfx $ctg_stringendswith { - if {[string match "*$pfx" $v]} { - set member_satisfied 1 - lset newtypelist $tpidx validated-$tp - break - } - } - } - - - - if {$member_satisfied} { - if {$clause_member_optional && $alloc_count >= [llength $all_remaining]} { - if {[dict exists $ARG_INFO $thisname -typedefaults]} { - set d [lindex [dict get $ARG_INFO $thisname -typedefaults] $tpidx] - lappend resultlist $d - lset newtypelist $tpidx ?defaulted-$tp? - } else { - lset newtypelist $tpidx ?omitted-$tp? - lappend resultlist "" - } - } else { - #may have satisfied one of the basic type tests above - lappend resultlist $v - incr alloc_count - } - } else { - if {$clause_member_optional} { - if {[dict exists $ARG_INFO $thisname -typedefaults]} { - set d [lindex [dict get $ARG_INFO $thisname -typedefaults] $tpidx] - lappend resultlist $d - lset newtypelist $tpidx ?defaulted-$tp? - } else { - lappend resultlist "" - lset newtypelist $tpidx ?omitted-$tp? - } - } else { - set alloc_ok 0 - } - } - - if {$alloc_count > [llength $all_remaining]} { - set alloc_ok 0 - break - } - incr tpidx - } - - #?omitted-*? and ?defaulted-*? in typelist are a way to know which elements in the clause were missing/defaulted - #so that they are not subject to type validation - #such elements shouldn't be subject to validation - if {$alloc_ok} { - #puts stderr ">>>_get_dict_can_assign_value idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" - set d [dict create consumed $alloc_count resultlist $resultlist typelist $newtypelist] - } else { - puts stderr ">>>_get_dict_can_assign_value NOT alloc_ok: idx:$idx v:[lindex $values $idx] consumed:$alloc_count thistype:$thistype" - set d [dict create consumed 0 resultlist {} typelist $thistype] - } - #puts ">>>> _get_dict_can_assign_value $d" - return $d - } - - #_split_type_expression - #only handles toplevel 'or' for type_expression e.g int|char - #we have no mechanism for & - (although it would be useful) - #more complex type_expressions would require a bracketing syntax - (and probably pre-parsing) - #or perhaps more performant, RPN to avoid bracket parsing - #if literal(..), literalprefix(..), stringstartswith(..) etc can have pipe symbols and brackets etc - we can't just use split - #if we require -type to always be treated as a list - and if an element is length 1 - require it to - #have properly balanced brackets that don't contain | ( ) etc we can simplify - REVIEW - - #consider: - #1 basic syntax - only OR supported - limits on what chars can be put in 'textn' elements. - #mode -type literalprefix(text1)|literalprefix(text2) -optional 1 - #2 expanded syntax - supports arbitrary chars in 'textn' elements - but still doesn't support more complex OR/AND logic - #mode -type {{literalprefix text1 | literalprefix text2}} - #3 RPN (reverse polish notation) - somewhat unintuitive, but allows arbitrary textn, and complex OR/AND logic without brackets. - #(forth like - stack based definition of types) - #mode -type {literalprefix text1 literalprefix text2 OR} - #mode -type {stringstartswith x stringstartswith y OR stringendswith z AND int OR} - - proc _split_type_expression {type_expression} { - if {[llength $type_expression] == 1} { - #simple expressions of length one must be splittable on | - #disallowed: things such as literal(|) or literal(x|etc)|int - #these would have to be expressed as {literal |} and {literal x|etc | int} - set or_type_parts [split $type_expression |] - set type_alternatives [list] - foreach t $or_type_parts { - if {[regexp {([^\(^\)]*)\((.*)\)$} $t _ name val]} { - lappend type_alternatives [list $name $val] - } else { - lappend type_alternatives $t - } - } - return $type_alternatives - } else { - error "_split_type_expression unimplemented: type_expression length > 1 '$type_expression'" - #todo - #RPN reverse polish notation - #e.g {stringstartswith x stringstartswith y OR stringendswith z AND int OR} - #equivalent logic: ((stringstartswith(x)|stringstartswith(y))&stringendswith(z))|int - # {int ; stringstartswith x stringstartswith y OR } - - #experimental.. seems like a pointless syntax. - #may as well just use list of lists with |(or) as the intrinsic operator instead of parsing this - #e.g {stringstartswith x | literal | | int} - set type_alternatives [list] - set expect_separator 0 - for {set w 0} {$w < [llength $type_expression]} {incr w} { - set word [lindex $type_expression $w] - if {$expect_separator} { - if {$word eq "|"} { - #pipe could be last entry - not strictly correct, but can ignore - set expect_separator 0 - continue - } else { - error "_split_type_expression expected separator but received '$word' in type_expression:'$type_expression'" - } - } - switch -exact -- $word { - literal - literalprefix - stringstartswith - stringendswith - stringcontains { - if {$w+1 > [llength $type_expression]} { - #premature end - no arg available for type which requires one - error "_split_type_expression missing argument for type '$word' in type_expression:'$type_expression'" - } - lappend type_alternatives [list $word [lindex $type_expression $w+1]] - incr w ;#consume arg - set expect_separator 1 - } - default { - #simple types such as int,double,string - lappend type_alternatives $word - set expect_separator 1 - } - } - } - return $type_alternatives - } - } - - #old version - ###proc _check_clausecolumn {argname argclass thisarg thisarg_checks clausecolumn type_expression clausevalues_raw clausevalues_check argspecs} { - ### #set type $type_expression ;#todo - 'split' on | - ### set vlist $clausevalues_raw - ### set vlist_check $clausevalues_check - - ### set type_alternatives [_split_type_expression $type_expression] - ### #each type_alternative is a list of varying length depending on arguments supported by first word. - ### #TODO? - ### #single element types: int double string etc - ### #two element types literal literalprefix stringstartswith stringendswith - ### #TODO - ### set stype [lindex $type_alternatives 0] - ### #e.g int - ### #e.g {literal blah)etc} - ### set type [lindex $stype 0] - ### #switch on first word of each stype - ### # - - ### #review - for leaders,values - do we need to check literal etc? already checked during split into prevalues postvalues ? - ### switch -- $type { - ### any {} - ### literal { - ### foreach clauseval $vlist { - ### set e [lindex $clauseval $clausecolumn] - ### set testval [lindex $stype 1] - ### if {$e ne $testval} { - ### set msg "$argclass '$argname' for %caller% requires literal value '$testval'. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### stringstartwith { - ### foreach clauseval $vlist { - ### set e [lindex $clauseval $clausecolumn] - ### set testval [lindex $stype 1] - ### if {![string match $testval* $e]} { - ### set msg "$argclass '$argname' for %caller% requires stringstartswith value '$argname'. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### list { - ### foreach clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {![tcl::string::is list -strict $e_check]} { - ### set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs]] $msg - ### } - ### if {[tcl::dict::size $thisarg_checks]} { - ### tcl::dict::for {checkopt checkval} $thisarg_checks { - ### switch -- $checkopt { - ### -minsize { - ### # -1 for disable is as good as zero - ### if {[llength $e_check] < $checkval} { - ### set msg "$argclass '$argname for %caller% requires list with -minsize $checkval. Received len:[llength $e_check]" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - ### } - ### } - ### -maxsize { - ### if {$checkval ne "-1"} { - ### if {[llength $e_check] > $checkval} { - ### set msg "$argclass '$argname for %caller% requires list with -maxsize $checkval. Received len:[llength $e_check]" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $checkval] -badarg $e_check -badval $e_check -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### } - ### } - ### } - ### } - ### } - ### indexexpression { - ### foreach clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {[catch {lindex {} $e_check}]} { - ### set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### string - ansistring - globstring { - ### #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - ### #we possibly don't want to always have to regex on things that don't pass the other more basic checks - ### # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - ### # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - ### # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - ### # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - ### # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - ### # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - ### #todo? - way to validate both unstripped and stripped? - ### set pass_quick_list_e [list] - ### set pass_quick_list_e_check [list] - ### set remaining_e $vlist - ### set remaining_e_check $vlist_check - ### #review - order of -regexprepass and -regexprefail in original rawargs significant? - ### #for now -regexprepass always takes precedence - ### set regexprepass [tcl::dict::get $thisarg -regexprepass] - ### set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - ### if {$regexprepass ne ""} { - ### foreach clauseval $vlist clauseval_check $vlist_check { - ### set e [lindex $clauseval $clausecolumn] - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {[regexp [lindex $regexprepass $clausecolumn] $e]} { - ### lappend pass_quick_list_e $clauseval - ### lappend pass_quick_list_e_check $clauseval_check - ### } - ### } - ### set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] - ### set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] - ### } - ### if {$regexprefail ne ""} { - ### foreach clauseval $remaining_e clauseval_check $remaining_e_check { - ### set e [lindex $clauseval $clausecolumn] - ### set e_check [lindex $clauseval_check $clausecolumn] - ### #puts "----> checking $e vs regex $regexprefail" - ### if {[regexp $regexprefail $e]} { - ### if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - ### #review - %caller% ?? - ### set msg [tcl::dict::get $thisarg -regexprefailmsg] - ### } else { - ### set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - ### } - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### switch -- $type { - ### ansistring { - ### #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - ### #.. so we need to look at the original values in $vlist not $vlist_check - - ### #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - ### #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - ### package require punk::ansi - ### foreach clauseval $remaining_e { - ### set e [lindex $clauseval $clausecolumn] - ### if {![punk::ansi::ta::detect $e]} { - ### set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### globstring { - ### foreach clauseval $remaining_e { - ### set e [lindex $clauseval $clausecolumn] - ### if {![regexp {[*?\[\]]} $e]} { - ### set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### } - - ### if {[tcl::dict::size $thisarg_checks]} { - ### foreach clauseval $remaining_e_check { - ### set e_check [lindex $clauseval $clausecolumn] - ### if {[dict exists $thisarg_checks -minsize]} { - ### set minsize [dict get $thisarg_checks -minsize] - ### # -1 for disable is as good as zero - ### if {[tcl::string::length $e_check] < $minsize} { - ### set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### if {[dict exists $thisarg_checks -maxsize]} { - ### set maxsize [dict get $thisarg_checks -maxsize] - ### if {$checkval ne "-1"} { - ### if {[tcl::string::length $e_check] > $maxsize} { - ### set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### } - ### } - ### } - ### number { - ### #review - consider effects of Nan and Inf - ### #NaN can be considered as 'technically' a number (or at least a special numeric value) - ### foreach clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { - ### set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### if {[tcl::dict::exists $thisarg -typeranges]} { - ### set ranges [tcl::dict::get $thisarg -typeranges] - ### foreach clauseval $vlist clauseval_check $vlist_check { - ### set e [lindex $clauseval $clausecolumn] - ### set e_check [lindex $clauseval_check $clausecolumn] - ### set range [lindex $ranges $clausecolumn] - ### lassign {} low high ;#set both empty - ### lassign $range low high - - ### if {"$low$high" ne ""} { - ### if {[::tcl::mathfunc::isnan $e]} { - ### set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### if {$low eq ""} { - ### if {$e_check > $high} { - ### set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } elseif {$high eq ""} { - ### if {$e_check < $low} { - ### set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } else { - ### if {$e_check < $low || $e_check > $high} { - ### set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### } - ### } - ### } - ### int { - ### #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - ### foreach clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {![tcl::string::is integer -strict $e_check]} { - ### set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### if {[tcl::dict::exists $thisarg -typeranges]} { - ### set ranges [tcl::dict::get $thisarg -typeranges] - ### foreach clauseval $vlist clauseval_check $vlist_check { - ### set e [lindex $clauseval $clausecolumn] - ### set e_check [lindex $clauseval_check $clausecolumn] - ### set range [lindex $ranges $clausecolumn] - ### lassign $range low high - ### if {"$low$high" ne ""} { - ### if {$low eq ""} { - ### #lowside unspecified - check only high - ### if {$e_check > $high} { - ### set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } elseif {$high eq ""} { - ### #highside unspecified - check only low - ### if {$e_check < $low} { - ### set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } else { - ### #high and low specified - ### if {$e_check < $low || $e_check > $high} { - ### set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### } - ### } - ### } - ### double { - ### foreach clauseval $vlist clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {![tcl::string::is double -strict $e_check]} { - ### set e [lindex $clauseval $clausecolumn] - ### set msg "$argclass $argname for %caller% requires type double. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### if {[tcl::dict::size $thisarg_checks]} { - ### if {[dict exists $thisarg_checks -typeranges]} { - ### set ranges [dict get $thisarg_checks -typeranges] - ### foreach clauseval $vlist clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### set range [lindex $ranges $clausecolumn] - ### #todo - small-value double comparisons with error-margin? review - ### #todo - empty string for low or high - ### lassign $range low high - ### if {$e_check < $low || $e_check > $high} { - ### set e [lindex $clauseval $clausecolumn] - ### set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### } - ### } - ### bool { - ### foreach clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {![tcl::string::is boolean -strict $e_check]} { - ### set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### dict { - ### foreach clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {[llength $e_check] %2 != 0} { - ### set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - ### } - ### } - ### if {[tcl::dict::size $thisarg_checks]} { - ### if {[dict exists $thisarg_checks -minsize]} { - ### set minsizes [dict get $thisarg_checks -minsize] - ### foreach clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### set minsize [lindex $minsizes $clausecolumn] - ### # -1 for disable is as good as zero - ### if {[tcl::dict::size $e_check] < $minsize} { - ### set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### if {[dict exists $thisarg_checks -maxsize]} { - ### set maxsizes [dict get $thisarg_checks -maxsize] - ### foreach clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### set maxsize [lindex $maxsizes $clausecolumn] - ### if {$maxsize ne "-1"} { - ### if {[tcl::dict::size $e_check] > $maxsize} { - ### set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### } - ### } - ### } - ### alnum - - ### alpha - - ### ascii - - ### control - - ### digit - - ### graph - - ### lower - - ### print - - ### punct - - ### space - - ### upper - - ### wordchar - - ### xdigit { - ### foreach clauseval $vlist clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {![tcl::string::is $type -strict $e_check]} { - ### set e [lindex $clauseval $t] - ### set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### file - - ### directory - - ### existingfile - - ### existingdirectory { - ### foreach clauseval $vlist clauseval_check $vlist_check { - ### set e [lindex $clauseval $clausecolumn] - ### set e_check [lindex $clauseval_check $clausecolumn] - ### #//review - we may need '?' char on windows - ### if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - ### #what about special file names e.g on windows NUL ? - ### set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - ### } - ### if {$type eq "existingfile"} { - ### if {![file exists $e_check]} { - ### set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - ### } - ### } elseif {$type eq "existingdirectory"} { - ### if {![file isdirectory $e_check]} { - ### set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### } - ### char { - ### #review - char vs unicode codepoint vs grapheme? - ### foreach clauseval $vlist clauseval_check $vlist_check { - ### set e_check [lindex $clauseval_check $clausecolumn] - ### if {[tcl::string::length $e_check] != 1} { - ### set e [lindex $clauseval $clausecolumn] - ### set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - ### return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - ### } - ### } - ### } - ### default { - ### } - ### } - - ###} - - #new version - #list_of_clauses_raw list of (possibly)multi-value clauses for a particular argname - #common basic case: list of single item being a single value clause. - #precondition: list_of_clauses_raw has 'list protected' clauses of length 1 e.g if value is a dict {a A} - proc _check_clausecolumn {argname argclass thisarg thisarg_checks clausecolumn default_type_expression list_of_clauses_raw list_of_clauses_check list_of_clauses_types argspecs} { - #default_type_expression is for the chosen clausecolumn - #if {$argname eq "frametype"} { - #puts "--->checking arg:$argname clausecolumn:$clausecolumn checkvalues:[lsearch -all -inline -index $clausecolumn -subindices $list_of_clauses_check *] against default_type_expression $default_type_expression" - #puts "--->list_of_clauses_raw : $list_of_clauses_raw" - #puts "--->list_of_clauses_check: $list_of_clauses_check" - #puts "--->$argname -type: [dict get $thisarg -type]" - #} - - set clause_size [llength [dict get $thisarg -type]] ;#length of full type - not just the default_type_expression for the clausecolumn - - set default_type_alternatives [_split_type_expression $default_type_expression] - #--------------------- - #pre-calc prefix sets based on the default. - set alt_literals [lsearch -all -inline -index 0 $default_type_alternatives literal] - set literals [lmap v $alt_literals {lindex $v 1}] - set alt_literalprefixes [lsearch -all -inline -index 0 $default_type_alternatives literalprefix] - set literalprefixes [lmap v $alt_literalprefixes {lindex $v 1}] - #--------------------- - - #each type_alternative is a list of varying length depending on arguments supported by first word. - #TODO? - #single element types: int double string etc - #two element types literal literalprefix stringstartswith stringendswith - #TODO - - #list for each clause (each clause is itself a list - usually length 1 but can be any length - we are dealing only with one column of the clauses) - set clause_results [lrepeat [llength $list_of_clauses_raw] [lrepeat [llength $default_type_alternatives] _]] - #e.g for list_of_clauses_raw {{a b c} {1 2 3}} when clausecolumn is 0 - #-types {int|char|literal(ok) char double} - #we are checking a and 1 against the defaulttype_expression e.g int|char|literal(ok) (type_alternatives = {int char literal(ok)} - #our initial clause_results in this case is a 2x2 list {{_ _ _} {_ _ _}} - #review: for a particular clause the active type_expression might be overridden with 'any' if the column has already passed a -choices test - # - - set e_vals [lsearch -all -inline -index $clausecolumn -subindices $list_of_clauses_raw *] - set check_vals [lsearch -all -inline -index $clausecolumn -subindices $list_of_clauses_check *] - set typelist_vals_raw [lsearch -all -inline -index $clausecolumn -subindices $list_of_clauses_types *] - set typelist_vals [lmap v $typelist_vals_raw {string trim $v ?}] - - set c_idx -1 - foreach e $e_vals e_check $check_vals clause_column_type_expression $typelist_vals { - incr c_idx - set col_type_alternatives [_split_type_expression $clause_column_type_expression] - set firstany [lsearch -exact $col_type_alternatives any] - if {$firstany > -1} { - lset clause_results $c_idx $firstany 1 - continue - } - set a_idx -1 - foreach typealt $col_type_alternatives { - incr a_idx - lassign $typealt type testval ;#testval will be empty for basic types, but applies to literal, literalprefix, stringstartswith etc. - switch -exact -- $type { - literal { - if {$e ne $testval} { - set msg "$argclass '$argname' for %caller% requires literal value '$testval'. Received: '$e'" - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] - } else { - lset clause_results $c_idx $a_idx 1 - #this clause is satisfied - no need to process it for other typealt - break - } - } - literalprefix { - #this specific literalprefix testval value not relevant - we're testing against all in the set of typealternates - set match [::tcl::prefix::match -error "" [list {*}$literals {*}$literalprefixes] $e] - if {$match ne "" && $match ni $literals} { - lset clause_results $c_idx $a_idx 1 - #this clause is satisfied - no need to process it for other typealt - break - } else { - set msg "$argclass '$argname' for %caller% requires unambiguous literal prefix match for one of '$literalprefixes' within prefix calculation set:'[list {*}$literals {*}$literalprefixes]'. Received: '$e'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] - } - } - stringstartswith { - if {[string match $testval* $e]} { - lset clause_results $c_idx $a_idx 1 - break - } else { - set msg "$argclass '$argname' for %caller% requires stringstartswith value '$testval'. Received: '$e'" - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] - } - } - stringendswith { - if {[string match *$testval $e]} { - lset clause_results $c_idx $a_idx 1 - break - } else { - set msg "$argclass '$argname' for %caller% requires stringendswith value '$testval'. Received: '$e'" - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] - } - } - list { - if {![tcl::string::is list -strict $e_check]} { - set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs] msg $msg] - continue - } else { - if {[dict exists $thisarg_checks -minsize]} { - # -1 for disable is as good as zero - set minsize [dict get $thisarg_checks -minsize] - if {[llength $e_check] < $minsize} { - set msg "$argclass '$argname for %caller% requires list with -minsize $minsize. Received len:[llength $e_check]" - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $e_check -badval $e_check -argspecs $argspecs] msg $msg] - continue - } - } - if {[dict exist $thisarg_checks -maxsize]} { - set maxsize [dict get $thisarg_checks -maxsize] - if {$maxsize ne "-1"} { - if {[llength $e_check] > $maxsize} { - set msg "$argclass '$argname for %caller% requires list with -maxsize $maxsize. Received len:[llength $e_check]" - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $e_check -badval $e_check -argspecs $argspecs] msg $msg] - continue - } - } - } - } - lset clause_results $c_idx $a_idx 1 - break - } - indexexpression { - if {[catch {lindex {} $e_check}]} { - set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - } else { - lset clause_results $c_idx $a_idx 1 - break - } - } - string - ansistring - globstring { - #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - #todo? - way to validate both unstripped and stripped? - #review - order of -regexprepass and -regexprefail in original rawargs significant? - #for now -regexprepass always takes precedence - #REVIEW we only have a single regexprepass/regexprefail for entire typeset?? need to make it a list like -typedefaults? - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - if {$regexprepass ne ""} { - if {[regexp [lindex $regexprepass $clausecolumn] $e]} { - lset clause_results $c_idx $a_idx 1 - break - } - } - if {$regexprefail ne ""} { - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - #review - %caller% ?? - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs] msg $msg] - #review - tests? - continue - } - } - switch -- $type { - ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - #.. so we need to look at the original values in $clauses_dict not $clauses_dict_check - - #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - package require punk::ansi - if {![punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - } - globstring { - if {![regexp {[*?\[\]]} $e]} { - set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - if {[dict exists $thisarg_checks -minsize]} { - set minsize [dict get $thisarg_checks -minsize] - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $minsize} { - set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - } - if {[dict exists $thisarg_checks -maxsize]} { - set maxsize [dict get $thisarg_checks -maxsize] - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $maxsize} { - set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - } - } - } - lset clause_results $c_idx $a_idx 1 - break - } - number { - #review - consider effects of Nan and Inf - #NaN can be considered as 'technically' a number (or at least a special numeric value) - if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - if {[tcl::dict::exists $thisarg -typeranges]} { - set ranges [tcl::dict::get $thisarg -typeranges] - set range [lindex $ranges $clausecolumn] - lassign {} low high ;#set both empty - lassign $range low high - if {"$low$high" ne ""} { - if {[::tcl::mathfunc::isnan $e]} { - set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - if {$low eq ""} { - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - } elseif {$high eq ""} { - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - } else { - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - } - } - } - lset clause_results $c_idx $a_idx 1 - break - } - int { - #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - if {![tcl::string::is integer -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - if {[tcl::dict::exists $thisarg -typeranges]} { - set ranges [tcl::dict::get $thisarg -typeranges] - set range [lindex $ranges $clausecolumn] - lassign $range low high - if {"$low$high" ne ""} { - if {$low eq ""} { - #lowside unspecified - check only high - if {$e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - } elseif {$high eq ""} { - #highside unspecified - check only low - if {$e_check < $low} { - set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - } else { - #high and low specified - if {$e_check < $low || $e_check > $high} { - set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - } - } - } - lset clause_results $c_idx $a_idx 1 - break - } - double { - if {![tcl::string::is double -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type double. Received: '$e'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - if {[tcl::dict::exists $thisarg_checks -typeranges]} { - set ranges [dict get $thisarg_checks -typeranges] - set range [lindex $ranges $clausecolumn] - #todo - small-value double comparisons with error-margin? review - lassign $range low high - if {$low$high ne ""} { - if {$low eq ""} { - #lowside unspecified - check only high - if {$e_check > $high} { - set msg "$argclass $argname for %caller% must be double less than or equal to $high. Received: '$e'" - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - } elseif {$high eq ""} { - #highside unspecified - check only low - if {$e_check < $low} { - set msg "$argclass $argname for %caller% must be double greater than or equal to $low. Received: '$e'" - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - } elseif {$e_check < $low || $e_check > $high} { - set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } - } - } - lset clause_results $c_idx $a_idx 1 - break - } - bool { - if {![tcl::string::is boolean -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - continue - } else { - lset clause_results $c_idx $a_idx 1 - break - } - } - dict { - if {[llength $e_check] %2 != 0} { - set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] - continue - } - if {[tcl::dict::size $thisarg_checks]} { - if {[dict exists $thisarg_checks -minsize]} { - set minsizes [dict get $thisarg_checks -minsize] - set minsize [lindex $minsizes $clausecolumn] - # -1 for disable is as good as zero - if {[tcl::dict::size $e_check] < $minsize} { - set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]" - lset clause_results $c_idx $a_idx [list err [list sizeviolation $type minsize $minsize] msg $msg] - continue - } - } - if {[dict exists $thisarg_checks -maxsize]} { - set maxsize [lindex $maxsizes $clausecolumn] - if {$maxsize ne "-1"} { - if {[tcl::dict::size $e_check] > $maxsize} { - set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]" - lset clause_results $c_idx $a_idx [list err [list sizeviolation $type maxsize $maxsize] msg $msg] - continue - } - } - } - } - lset clause_results $c_idx $a_idx 1 - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - if {![tcl::string::is $type -strict $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" - lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] - continue - } else { - lset clause_results $c_idx $a_idx 1 - break - } - } - file - - directory - - existingfile - - existingdirectory { - #//review - we may need '?' char on windows - if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - #what about special file names e.g on windows NUL ? - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] - continue - } - if {$type eq "existingfile"} { - if {![file exists $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] - continue - } - } elseif {$type eq "existingdirectory"} { - if {![file isdirectory $e_check]} { - set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] - continue - } - } - lset clause_results $c_idx $a_idx 1 - } - char { - #review - char vs unicode codepoint vs grapheme? - if {[tcl::string::length $e_check] != 1} { - set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] - continue - } else { - lset clause_results $c_idx $a_idx 1 - break - } - } - tk_screen_units { - switch -exact -- [string index $e_check end] { - c - i - m - p { - set numpart [string range $e_check 0 end-1] - if {![tcl::string::is double $numpart]} { - set msg "$argclass $argname for %caller% requires type 'tk_screen_units'. Received: '$e' Which does not seem to be in a form as accepted ty Tk_GetPixels." - lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] - continue - } - } - default { - if {![tcl::string::is double $e_check]} { - set msg "$argclass $argname for %caller% requires type 'tk_screen_units'. Received: '$e' Which does not seem to be in a form as accepted ty Tk_GetPixels." - lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] - continue - } - } - } - lset clause_results $c_idx $a_idx 1 - break - } - default { - #default pass for unrecognised types - review. - lset clause_results $c_idx $a_idx 1 - break - } - } - } - } - - foreach clauseresult $clause_results { - if {[lsearch $clauseresult 1] == -1} { - #no pass for this clause - fetch first? error and raise - #todo - return error containing clause_indices so we can report more than one failing element at once? - foreach e $clauseresult { - switch -exact [lindex $e 0] { - errorcode { - #errorcode msg checking arg:$argname clausecolumn:$clausecolumn checkvalues:[lsearch -all -inline -index $clausecolumn -subindices $list_of_clauses_check *] against type_expression $type_expression" - # puts "--->list_of_clauses_raw : $list_of_clauses_raw" - # puts "--->list_of_clauses_check: $list_of_clauses_check" - # puts "--->$argname -type: [dict get $thisarg -type]" - # } - - # set clause_size [llength [dict get $thisarg -type]] ;#length of full type - not just passed type_expression - - # #set vlist [list] - # set clauses_dict [dict create] ;#key is ordinal position, remove entries as they are satsified - # set cidx -1 - # foreach cv $list_of_clauses_raw { - # incr cidx - # #REVIEW - # #if {$clause_size ==1} { - # # lappend vlist [list $cidx [list $cv]] - # #} else { - # #lappend vlist [list $cidx $cv] ;#store the index so we can reduce vlist as we go - # dict set clauses_dict $cidx $cv - # #} - # } - # #set vlist_check [list] - # set clauses_dict_check [dict create] - # set cidx -1 - # foreach cv $list_of_clauses_check { - # incr cidx - # #if {$clause_size == 1} { - # # lappend vlist_check [list $cidx [list $cv]] - # #} else { - # #lappend vlist_check [list $cidx $cv] - # dict set clauses_dict_check $cidx $cv - # #} - # } - - # set type_alternatives [_split_type_expression $type_expression] - # #each type_alternative is a list of varying length depending on arguments supported by first word. - # #TODO? - # #single element types: int double string etc - # #two element types literal literalprefix stringstartswith stringendswith - # #TODO - - # #list for each clause (each clause is itself a list - usually length 1 but can be any length - we are dealing only with one column of the clauses) - # set clause_results [lrepeat [llength $list_of_clauses_raw] [lrepeat [llength $type_alternatives] _]] - # #e.g for list_of_clauses_raw {{a b c} {1 2 3}} when clausecolumn is 0 - # #-types {int|char|literal(ok) char double} - # #we are checking a and 1 against the type_expression int|char|literal(ok) (type_alternatives = {int char literal(ok)} - # #our initial clause_results in this case is a 2x2 list {{_ _ _} {_ _ _}} - # # - - - # set a_idx -1 - # foreach typealt $type_alternatives { - # incr a_idx - - # set type [lindex $typealt 0] - # #e.g int - # #e.g {literal blah} - # #e.g {literalprefix abc} - - # #switch on first word of each typealt - # # - - # #review - for leaders,values - do we need to check literal etc? already checked during split into prevalues postvalues ? - # switch -- $type { - # any {} - # literal { - # dict for {c_idx clauseval} $clauses_dict { - # set e [lindex $clauseval $clausecolumn] - # set testval [lindex $typealt 1] - # if {$e ne $testval} { - # set msg "$argclass '$argname' for %caller% requires literal value '$testval'. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] - # } else { - # lset clause_results $c_idx $a_idx 1 - # #this clause is satisfied - no need to process it for other typealt - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # literalprefix { - # set alt_literals [lsearch -all -inline -index 0 $type_alternatives literal] - # set literals [lmap v $alt_literals {lindex $v 1}] - # set alt_literalprefixes [lsearch -all -inline -index 0 $type_alternatives literalprefix] - # set literalprefixes [lmap v $alt_literalprefixes {lindex $v 1}] - - # dict for {c_idx clauseval} $clauses_dict { - # set e [lindex $clauseval $clausecolumn] - # #this specific literalprefix value not relevant - we're testing against all in the set of typealternates - # #set testval [lindex $typealt 1] - # set match [::tcl::prefix::match -error "" [list {*}$literals {*}$literalprefixes] $e] - # if {$match ne "" && $match ni $literals} { - # lset clause_results $c_idx $a_idx 1 - # #this clause is satisfied - no need to process it for other typealt - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } else { - # set msg "$argclass '$argname' for %caller% requires unambiguous literal prefix match for one of '$literalprefixes' within prefix calculation set:'[list {*}$literals {*}$literalprefixes]'. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] - # } - # } - # } - # stringstartswith { - # dict for {c_idx clauseval} $clauses_dict { - # set e [lindex $clauseval $clausecolumn] - # set testval [lindex $typealt 1] - # if {[string match $testval* $e]} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } else { - # set msg "$argclass '$argname' for %caller% requires stringstartswith value '$testval'. Received: '$e'" - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] - # } - # } - # } - # stringendswith { - # dict for {c_idx clauseval} $clauses_dict { - # set e [lindex $clauseval $clausecolumn] - # set testval [lindex $typealt 1] - # if {[string match *$testval $e]} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } else { - # set msg "$argclass '$argname' for %caller% requires stringendswith value '$testval'. Received: '$e'" - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e -argspecs $argspecs] msg $msg] - # } - # } - # } - # list { - # dict for {c_idx clauseval_check} $clauses_dict_check { - # set e_check [lindex $clauseval_check $clausecolumn] - # set passed_checks 1 - # if {![tcl::string::is list -strict $e_check]} { - # set msg "$argclass '$argname' for %caller% requires type 'list'. Received: '$e_check'" - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $e_check -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } else { - # if {[dict exists $thisarg_checks -minsize]} { - # # -1 for disable is as good as zero - # set minsize [dict get $thisarg_checks -minsize] - # if {[llength $e_check] < $minsize} { - # set msg "$argclass '$argname for %caller% requires list with -minsize $minsize. Received len:[llength $e_check]" - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $e_check -badval $e_check -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # if {$passed_checks && [dict exist $thisarg_checks -maxsize]} { - # set maxsize [dict get $thisarg_checks -maxsize] - # if {$maxsize ne "-1"} { - # if {[llength $e_check] > $maxsize} { - # set msg "$argclass '$argname for %caller% requires list with -maxsize $maxsize. Received len:[llength $e_check]" - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $e_check -badval $e_check -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # } - # } - # if {$passed_checks} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # indexexpression { - # dict for {c_idx clauseval_check} $clauses_dict_check { - # set e_check [lindex $clauseval_check $clausecolumn] - # if {[catch {lindex {} $e_check}]} { - # set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # } else { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # string - ansistring - globstring { - # #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string - # #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) - # # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) - # # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function - # # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) - # # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail - - # #todo? - way to validate both unstripped and stripped? - # #review - order of -regexprepass and -regexprefail in original rawargs significant? - # #for now -regexprepass always takes precedence - # #REVIEW we only have a single regexprepass/regexprefail for entire typeset?? need to make it a list like -typedefaults? - # set regexprepass [tcl::dict::get $thisarg -regexprepass] - # set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - # if {$regexprepass ne ""} { - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - # set e [lindex $clauseval $clausecolumn] - # set e_check [lindex $clauseval_check $clausecolumn] - # if {[regexp [lindex $regexprepass $clausecolumn] $e]} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # if {$regexprefail ne ""} { - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - - # set e [lindex $clauseval $clausecolumn] - # set e_check [lindex $clauseval_check $clausecolumn] - # #puts "----> checking $e vs regex $regexprefail" - # if {[regexp $regexprefail $e]} { - # if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - # #review - %caller% ?? - # set msg [tcl::dict::get $thisarg -regexprefailmsg] - # } else { - # set msg "$argclass $argname for %caller% didn't pass regexprefail regex: '$regexprefail' got '$e'" - # } - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list regexprefail $type] -badarg $argname -argspecs $argspecs] msg $msg] - # #review - tests? - # } - # } - # } - # switch -- $type { - # ansistring { - # #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi - # #.. so we need to look at the original values in $clauses_dict not $clauses_dict_check - - # #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? - # #The ansicodes only case should be covered by -minsize 0 -maxsize 0 combined with -validate_ansistripped ??? - # package require punk::ansi - # dict for {c_idx clauseval} $clauses_dict { - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # set e [lindex $clauseval $clausecolumn] - # if {![punk::ansi::ta::detect $e]} { - # set msg "$argclass '$argname' for %caller% requires ansistring - but no ansi detected" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # } - # } - # } - # globstring { - # dict for {c_idx clauseval} $clauses_dict { - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # set e [lindex $clauseval $clausecolumn] - # if {![regexp {[*?\[\]]} $e]} { - # set msg "$argclass '$argname' for %caller% requires globstring - but no glob characters detected" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # } - # } - # } - # } - - # dict for {c_idx clauseval_check} $clauses_dict_check { - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # if {[tcl::dict::size $thisarg_checks]} { - # set passed_checks 1 - # set e_check [lindex $clauseval_check $clausecolumn] - # if {[dict exists $thisarg_checks -minsize]} { - # set minsize [dict get $thisarg_checks -minsize] - # # -1 for disable is as good as zero - # if {[tcl::string::length $e_check] < $minsize} { - # set msg "$argclass '$argname' for %caller% requires string with -minsize $minsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # if {$passed_checks && [dict exists $thisarg_checks -maxsize]} { - # set maxsize [dict get $thisarg_checks -maxsize] - # if {$checkval ne "-1"} { - # if {[tcl::string::length $e_check] > $maxsize} { - # set msg "$argclass '$argname' for %caller% requires string with -maxsize $maxsize. Received len:[tcl::string::length $e_check] value:'$e_check'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # } - # if {$passed_checks} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } else { - # if {[lindex $clause_results $c_idx $a_idx] eq "_"} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # } - # number { - # #review - consider effects of Nan and Inf - # #NaN can be considered as 'technically' a number (or at least a special numeric value) - # dict for {c_idx clauseval_check} $clauses_dict_check { - # set e_check [lindex $clauseval_check $clausecolumn] - # if {(![tcl::string::is integer -strict $e_check]) && (![tcl::string::is double -strict $e_check])} { - # set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # } - # } - # if {[tcl::dict::exists $thisarg -typeranges]} { - # set ranges [tcl::dict::get $thisarg -typeranges] - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # set e [lindex $clauseval $clausecolumn] - # set e_check [lindex $clauseval_check $clausecolumn] - # set range [lindex $ranges $clausecolumn] - # lassign {} low high ;#set both empty - # lassign $range low high - # set passed_checks 1 - # if {"$low$high" ne ""} { - # if {[::tcl::mathfunc::isnan $e]} { - # set msg "$argclass '$argname' for %caller% must be an int or double within specified range {'$low' '$high'} NaN not comparable to any range. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # if {$passed_checks} { - # if {$low eq ""} { - # if {$e_check > $high} { - # set msg "$argclass '$argname' for %caller% must be an int or double less than or equal to $high. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } elseif {$high eq ""} { - # if {$e_check < $low} { - # set msg "$argclass '$argname' for %caller% must be an int or double greater than or equal to $low. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } else { - # if {$e_check < $low || $e_check > $high} { - # set msg "$argclass '$argname' for %caller% must be an int or double between $low and $high inclusive. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # } - # } - # if {$passed_checks} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict usnet clauses_dict_check $c_idx - # } - # } - # } else { - # dict for {c_idx clauseval} $clauses_dict { - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict usnet clauses_dict_check $c_idx - # } - # } - - # } - # int { - # #elements in -typeranges can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive - # dict for {c_idx clauseval_check} $clauses_dict_check { - # set e_check [lindex $clauseval_check $clausecolumn] - # if {![tcl::string::is integer -strict $e_check]} { - # set msg "$argclass $argname for %caller% requires type integer. Received: '$e_check'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # } - # } - # if {[tcl::dict::exists $thisarg -typeranges]} { - # set ranges [tcl::dict::get $thisarg -typeranges] - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # set e [lindex $clauseval $clausecolumn] - # set e_check [lindex $clauseval_check $clausecolumn] - # set range [lindex $ranges $clausecolumn] - # lassign $range low high - # set passed_checks 1 - # if {"$low$high" ne ""} { - # if {$low eq ""} { - # #lowside unspecified - check only high - # if {$e_check > $high} { - # set msg "$argclass '$argname' for %caller% must be integer less than or equal to $high. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } elseif {$high eq ""} { - # #highside unspecified - check only low - # if {$e_check < $low} { - # set msg "$argclass '$argname' for %caller% must be integer greater than or equal to $low. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } else { - # #high and low specified - # if {$e_check < $low || $e_check > $high} { - # set msg "$argclass '$argname' for %caller% must be integer between $low and $high inclusive. Received: '$e'" - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # } - # if {$passed_checks} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } else { - # dict for {c_idx clauseval} $clauses_dict { - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # double { - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - # set e_check [lindex $clauseval_check $clausecolumn] - # if {![tcl::string::is double -strict $e_check]} { - # set e [lindex $clauseval $clausecolumn] - # set msg "$argclass $argname for %caller% requires type double. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # } - # } - # if {[tcl::dict::exists $thisarg_checks -typeranges]} { - # set ranges [dict get $thisarg_checks -typeranges] - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # set e_check [lindex $clauseval_check $clausecolumn] - # set range [lindex $ranges $clausecolumn] - # #todo - small-value double comparisons with error-margin? review - # #todo - empty string for low or high - # set passed_checks 1 - # lassign $range low high - # if {$low$high ne ""} { - # if {$e_check < $low || $e_check > $high} { - # set e [lindex $clauseval $clausecolumn] - # set msg "$argclass $argname for %caller% must be double between $low and $high. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list rangeviolation $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # if {$passed_checks} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } else { - # dict for {c_idx clauseval} $clauses_dict { - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # bool { - # dict for {c_idx clauseval_check} $clauses_dict_check { - # set e_check [lindex $clauseval_check $clausecolumn] - # if {![tcl::string::is boolean -strict $e_check]} { - # set msg "$argclass $argname for %caller% requires type boolean. Received: '$e_check'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # } else { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # dict { - # dict for {c_idx clauseval_check} $clauses_dict_check { - # puts "check_clausecolumn2 dict handler: c_idx:$c_idx clausecolumn:$clausecolumn clauseval_check:$clauseval_check" - # set e_check [lindex $clauseval_check $clausecolumn] - # if {[llength $e_check] %2 != 0} { - # set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg] - # } - # } - # dict for {c_idx clauseval_check} $clauses_dict_check { - # if {[lindex $clause_results $c_idx $a_idx] ne "_"} { - # continue - # } - # set passed_checks 1 - # if {[tcl::dict::size $thisarg_checks]} { - # if {[dict exists $thisarg_checks -minsize]} { - # set minsizes [dict get $thisarg_checks -minsize] - # set e_check [lindex $clauseval_check $clausecolumn] - # set minsize [lindex $minsizes $clausecolumn] - # # -1 for disable is as good as zero - # if {[tcl::dict::size $e_check] < $minsize} { - # set msg "$argclass '$argname' for %caller% requires dict with -minsize $minsize. Received dict size:[dict size $e_check]" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type minsize $minsize] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # if {$passed_checks && [dict exists $thisarg_checks -maxsize]} { - # set e_check [lindex $clauseval_check $clausecolumn] - # set maxsize [lindex $maxsizes $clausecolumn] - # if {$maxsize ne "-1"} { - # if {[tcl::dict::size $e_check] > $maxsize} { - # set msg "$argclass '$argname' for %caller% requires dict with -maxsize $maxsize. Received dict size:[dict size $e_check]" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list sizeviolation $type maxsize $maxsize] -badarg $argname -badval $e_check -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # } - # } - - # if {$passed_checks} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # alnum - - # alpha - - # ascii - - # control - - # digit - - # graph - - # lower - - # print - - # punct - - # space - - # upper - - # wordchar - - # xdigit { - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - # set e_check [lindex $clauseval_check $clausecolumn] - # if {![tcl::string::is $type -strict $e_check]} { - # set e [lindex $clauseval $t] - # set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e'" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # } else { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # file - - # directory - - # existingfile - - # existingdirectory { - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - - # set e [lindex $clauseval $clausecolumn] - # set e_check [lindex $clauseval_check $clausecolumn] - - # #//review - we may need '?' char on windows - # set passed_checks 1 - # if {!([tcl::string::length $e_check]>0 && ![regexp {[\"*<>\;]} $e_check])} { - # #what about special file names e.g on windows NUL ? - # set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # if {$passed_checks} { - # if {$type eq "existingfile"} { - # if {![file exists $e_check]} { - # set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing file" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } elseif {$type eq "existingdirectory"} { - # if {![file isdirectory $e_check]} { - # set msg "$argclass $argname for %caller% requires type '$type'. Received: '$e' which is not an existing directory" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # } - # if {$passed_checks} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # char { - # #review - char vs unicode codepoint vs grapheme? - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - - # set e_check [lindex $clauseval_check $clausecolumn] - # if {[tcl::string::length $e_check] != 1} { - # set e [lindex $clauseval $clausecolumn] - # set msg "$argclass $argname for %caller% requires type 'character'. Received: '$e' which is not a single character" - # #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs]] $msg - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] - # } else { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # tk_screen_units { - # dict for {c_idx clauseval} $clauses_dict { - # set clauseval_check [dict get $clauses_dict_check $c_idx] - - # set e_check [lindex $clauseval_check $clausecolumn] - # set passed_checks 1 - # switch -exact -- [string index $e_check end] { - # c - i - m - p { - # set numpart [string range $e_check 0 end-1] - # if {![tcl::string::is double $numpart]} { - # set e [lindex $clauseval $clausecolumn] - # set msg "$argclass $argname for %caller% requires type 'tk_screen_units'. Received: '$e' Which does not seem to be in a form as accepted ty Tk_GetPixels." - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # default { - # if {![tcl::string::is double $e_check]} { - # set e [lindex $clauseval $clausecolumn] - # set msg "$argclass $argname for %caller% requires type 'tk_screen_units'. Received: '$e' Which does not seem to be in a form as accepted ty Tk_GetPixels." - # lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -badval $e -argspecs $argspecs] msg $msg] - # set passed_checks 0 - # } - # } - # } - # if {$passed_checks} { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # default { - # #default pass for unrecognised types - review. - # dict for {c_idx clauseval} $clauses_dict { - # lset clause_results $c_idx $a_idx 1 - # dict unset clauses_dict $c_idx - # dict unset clauses_dict_check $c_idx - # } - # } - # } - # } - # foreach clauseresult $clause_results { - # if {[lsearch $clauseresult 1] == -1} { - # #no pass for this clause - fetch first? error and raise - # #todo - return error containing clause_indices so we can report more than one failing element at once? - # foreach e $clauseresult { - # if {[lindex $e 0] eq "errorcode"} { - # #errorcode msg values - #[para]ARGUMENTS: - #[list_begin arguments] - #[arg_def list-of-multiline-string deflist] - #[para] These are blocks of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced - #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values - #[para]Each optionspec line defining a flag must be of the form: - #[para]-optionname -key val -key2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices -optional etc - #[para]Each optionspec line defining a positional argument is of the form: - #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. - #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. - #[arg_def list rawargs] - #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, - #but it could be a manually constructed list of values made for example from positional args defined in the proc. - #[list_end] - #[para] - - #consider line-processing example below for which we need info complete to determine record boundaries - #punk::args::get_dict [list { - # @opts - # -opt1 -default {} - # -opt2 -default { - # etc - # } - # @values -multiple 1 - #}] $args - - - - - #rawargs: args values to be parsed - #we take a definition list rather than resolved argspecs - because the definition could be dynamic - - #if definition has been seen before, - #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. - set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]] - - # ----------------------------------------------- - # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars - #e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info,id_info,form_names - # ----------------------------------------------- - set opt_form [dict get $proc_opts -form] - if {$opt_form eq "*"} { - set selected_forms $form_names - } elseif {[string is integer -strict $opt_form]} { - if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list [lindex $form_names $opt_form]] - } else { - if {$opt_form ni $form_names} { - error "punk::args::get_dict invalid -form value '$opt_form' Expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" - } - set selected_forms [list $opt_form] - } - - - #puts "-arg_info->$arg_info" - set flagsreceived [list] ;#for checking if required flags satisfied - set solosreceived [list] - set multisreceived [list] - #secondary purpose: - #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. - #-default value must not be appended to if argname not yet in flagsreceived - - - #todo: -minmultiple -maxmultiple ? - - # -- --- --- --- - # Handle leading positionals - # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? - - #todo - handle multiple fids? - set fid [lindex $selected_forms 0] - set formdict [dict get $FORMS $fid] - tcl::dict::with formdict {} - #populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc - if {$VAL_MIN eq ""} { - set valmin 0 - #set VAL_MIN 0 - foreach v $VAL_REQUIRED { - # todo variable clause lengths (items marked optional in types using leading&trailing questionmarks) - # e.g -types {a ?xxx?} - #this has one required and one optional - set typelist [dict get $ARG_INFO $v -type] - set clause_length 0 - foreach t $typelist { - if {![string match {\?*\?} $t]} { - incr clause_length - } - } - incr valmin $clause_length - } - } else { - set valmin $VAL_MIN - } - - set pre_values {} - - set argnames [tcl::dict::keys $ARG_INFO] - #set optnames [lsearch -all -inline $argnames -*] - #JJJ - set lookup_optset [dict create] - foreach optset $OPT_NAMES { - #optset e.g {-x|--longopt|--longopt=|--otherlongopt} - foreach optdef [split $optset |] { - set opt [string trimright $optdef =] - if {![dict exists $lookup_optset $opt]} { - dict set lookup_optset $opt $optset - } - } - } - set all_opts [dict keys $lookup_optset] - - set ridx 0 - set rawargs_copy $rawargs - set remaining_rawargs $rawargs - set leader_posn_name "" - set leader_posn_names_assigned [dict create] ;#track if the name got a value (or multiple if last one) - set is_multiple 0 ;#last leader may be multi - - - #consider for example: LEADER_NAMES {"k v" leader2 leader3} with -type {int number} & -type {int int int} & -type string - #(i.e clause-length of 2 3 and 1) - #This will take 6 raw leaders to fill in the basic case that all are -optional 0 and -multiple 0 - #REVIEW - what about optional members in leaders e.g -type {int ?double?} - set named_leader_args_max 0 - foreach ln $LEADER_NAMES { - set typelist [dict get $ARG_INFO $ln -type] - incr named_leader_args_max [llength $typelist] - } - - #set id [dict get $argspecs id] - #if {$id eq "::if"} { - #puts stderr "::if" - #puts stderr "get_dict--> remaining_rawargs: $remaining_rawargs" - #} - - set can_have_leaders 1 ;#default assumption - if {$LEADER_MAX == 0 || ([llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED)} { - set can_have_leaders 0 - } - - #REVIEW - this attempt to classify leaders vs opts vs values doesn't account for leaders with clauses containing optional elements - #e.g @leaders {x -type {int ?int?}} - set nameidx 0 - if {$can_have_leaders} { - if {$LEADER_TAKEWHENARGSMODULO} { - #assign set of leaders purely based on number of total args - set take [expr {[llength $remaining_rawargs] % $LEADER_TAKEWHENARGSMODULO}] - set pre_values [lrange $remaining_rawargs 0 $take-1] - set remaining_rawargs [lrange $remaining_rawargs $take end] - } else { - #greedy taking of leaders based on type-matching - - set leadernames_seen [list] - for {set ridx 0} {$ridx < [llength $rawargs]} {incr ridx} { - set raw [lindex $rawargs $ridx] ;#received raw arg - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {[llength $LEADER_NAMES] && $nameidx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $nameidx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > $named_leader_args_max-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $nameidx] ;#may return empty string - } - if {$OPT_MAX ne "0" && [string match -* $raw]} { - #all_opts includes end_of_opts marker -- if configured - no need to explicitly check for it separately - set possible_flagname $raw - if {[string match --* $raw]} { - set eposn [string first = $raw] - # --flag=xxx - if {$eposn >=3} { - set possible_flagname [string range $raw 0 $eposn-1] - } - } - set matchopt [::tcl::prefix::match -error {} $all_opts $possible_flagname] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader - break - } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - set leader_type [dict get $ARG_INFO $leader_posn_name -type] - #todo - variable clauselengths e.g 'if' command which has optional 'then' and 'else' "noise words" - set clauselength [llength $leader_type] - set min_clauselength 0 - foreach t $leader_type { - if {![string match {\?*\?} $t]} { - incr min_clauselength - } - } - if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader - - #most adhoc arg processing will allocate based on number of args rather than matching choice values first - #(because a choice value could be a legitimate data value) - - #review - option to process in this manner? - #first check if the optional leader value is a match for a choice ? - #if {[dict exists $arg_info $leader_posn_name -choices]} { - # set vmatch [tcl::prefix match -error "" [dict get $arg_info $leader_posn_name -choices] $raw] - # if {$vmatch ne ""} { - # #If we match a choice for this named position - allocated it regardless of whether enough args for trailing values - # lappend pre_values [lpop remaining_rawargs 0] - # incr ridx - # continue - # } - #} - if {[llength $remaining_rawargs] < $min_clauselength} { - #not enough remaining args to fill even this optional leader - #rather than raise error here - perform our break (for end of leaders) and let the code below handle it - break - } - - #check if enough remaining_rawargs to fill any required values - if {$valmin > 0 && [llength $remaining_rawargs] - $min_clauselength < $valmin} { - break - } - - #leadername may be a 'clause' of arbitrary length (e.g -type {int double} or {int string number}) - set end_leaders 0 - set tentative_pre_values [list] - set tentative_idx $ridx - if {$OPT_MAX ne "0"} { - foreach t $leader_type { - set raw [lindex $rawargs $tentative_idx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { - #review - limitation of optional leaders is they can't be same value as any defined flags/opts - set flagname $raw - if {[string match --* $raw]} { - set eposn [string first = $raw] - # --flag=xxx - if {$eposn >=3} { - set flagname [string range $raw 0 $eposn-1] - } - } - set matchopt [::tcl::prefix::match -error {} $all_opts $flagname] - if {$matchopt ne ""} { - #don't consume if flaglike (and actually matches an opt) - set end_leaders 1 - break ;#break out of looking at -type members in the clause - } else { - #unrecognised flag - treat as value for optional member of the clause - #lappend pre_values [lpop remaining_rawargs 0] - lappend tentative_pre_values $raw - incr tentative_idx - } - } else { - #lappend pre_values [lpop remaining_rawargs 0] - lappend tentative_pre_values $raw - incr tentative_idx - } - } - if {$end_leaders} { - break - } - } else { - foreach t $leader_type { - #JJJ - set raw [lindex $rawargs $tentative_idx] - #lappend pre_values [lpop remaining_rawargs 0] - lappend tentative_pre_values $raw - incr tentative_idx - } - } - set assign_d [_get_dict_can_assign_value 0 $tentative_pre_values 0 [list $leader_posn_name] $leadernames_seen $formdict] - set consumed [dict get $assign_d consumed] - set resultlist [dict get $assign_d resultlist] - set newtypelist [dict get $assign_d typelist] - if {$consumed != 0} { - if {$leader_posn_name ni $leadernames_seen} { - lappend leadernames_seen $leader_posn_name - } - dict incr leader_posn_names_assigned $leader_posn_name - #for {set c 0} {$c < $consumed} {incr c} { - # lappend pre_values [lpop remaining_rawargs 0] - #} - lappend pre_values {*}[lrange $remaining_rawargs 0 $consumed-1] - ledit remaining_rawargs 0 $consumed-1 - - incr ridx $consumed - incr ridx -1 ;#leave ridx at index of last r that we set - } else { - - } - if {!$is_multiple} { - incr nameidx - } - } else { - #clause is required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one complete clause for this name - requirement satisfied - now equivalent to optional - if {[llength $remaining_rawargs] < $min_clauselength} { - #not enough remaining args to fill even this optional leader - #rather than raise error here - perform our break (for end of leaders) and let the code below handle it - break - } - - if {$valmin > 0 && [llength $remaining_rawargs] - $min_clauselength < $valmin} { - break - } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but still enough remaining_rawargs for required values - #we still need to check if enough values for the leader itself - if {[llength $remaining_rawargs] < $min_clauselength} { - #not enough remaining args to fill *required* leader - break - } - - set end_leaders 0 - - #review - are we allowing multivalue leader clauses where the optional members are not at the tail? - #eg @leaders {double -type {?int? char}} - #as we don't type-check here while determining leaders vs opts vs values - this seems impractical. - #for consistency and simplification - we should only allow optional clause members at the tail - # and only for the last defined leader. This should be done in the definition parsing - not here. - foreach t $leader_type { - set raw [lindex $rawargs $ridx] - if {[string match {\?*\?} $t] && [string match -* $raw]} { - #review - limitation of optional leaders is they can't be same value as any defined flags/opts - - set matchopt [::tcl::prefix::match -error {} $all_opts $raw] - if {$matchopt ne ""} { - #don't consume if flaglike (and actually matches an opt) - set end_leaders 1 - break ;#break out of looking at -type members in the clause - } else { - #unrecognised flag - treat as value for optional member of the clause - #ridx must be valid if we matched -* - so lpop will succeed - lappend pre_values [lpop remaining_rawargs 0] - incr ridx - } - } else { - if {[string match {\?*\?} $t]} { - if {$valmin > 0 && [llength $remaining_rawargs] - $min_clauselength < $valmin} { - set end_leaders 1 - break - } - if {[catch { - lappend pre_values [lpop remaining_rawargs 0] - }]} { - set end_leaders 1 - break - } - } else { - if {[catch { - lappend pre_values [lpop remaining_rawargs 0] - }]} { - set end_leaders 1 - break ;#let validation of required leaders report the error? - } - } - incr ridx - } - } - incr ridx -1 - if {$end_leaders} { - break - } - if {!$is_multiple} { - incr nameidx - } - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN-1} { - if {$LEADER_MAX ne "" && $ridx == $LEADER_MAX} { - break - } else { - if {$valmin > 0} { - if {[llength $remaining_rawargs] > $valmin} { - lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } else { - break - } - } else { - lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop remaining_rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #review - if is_multiple, keep going if enough remaining_rawargs for values? - break - } - } - - #incr ridx - } ;# end foreach r $rawargs_copy - } - } - #puts "get_dict ================> pre: $pre_values" - - set argstate $ARG_INFO ;#argstate may have entries added - set arg_checks $ARG_CHECKS - - if {$LEADER_MIN eq ""} { - set leadermin 0 - } else { - set leadermin $LEADER_MIN - } - if {$LEADER_MAX eq ""} { - if {[llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED} { - set leadermax 0 - } else { - set leadermax -1 - } - } else { - set leadermax $LEADER_MAX - } - - if {$VAL_MAX eq ""} { - if {[llength $VAL_NAMES] == 0 && !$VAL_UNNAMED} { - set valmax 0 - } else { - set valmax -1 - } - } else { - set valmax $VAL_MAX - } - - #assert leadermax leadermin are numeric - #assert - remaining_rawargs has been reduced by leading positionals - - set opts [dict create] ;#don't set to OPT_DEFAULTS here - - set leaders [list] - set arglist {} - set post_values {} - #valmin, valmax - #puts stderr "remaining_rawargs: $remaining_rawargs" - #puts stderr "argstate: $argstate" - if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] >= 0} { - #contains at least one possible flag - set maxidx [expr {[llength $remaining_rawargs] -1}] - if {$valmax == -1} { - set vals_total_possible [llength $remaining_rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $valmax - set vals_remaining_possible $vals_total_possible - } - for {set i 0} {$i <= $maxidx} {incr i} { - set remaining_args_including_this [expr {[llength $remaining_rawargs] - $i}] - #lowest valmin is 0 - if {$remaining_args_including_this <= $valmin} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - set a [lindex $remaining_rawargs $i] - switch -glob -- $a { - -- { - if {$a in $OPT_NAMES} { - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $remaining_rawargs 0 $i] - set post_values [lrange $remaining_rawargs $i+1 end] - } else { - #assume it's a value. - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - } - break - } - --* { - set eposn [string first = $a] - if {$eposn > 2} { - #only allow longopt-style = for double leading dash longopts - #--*= usage - if {$flagname ni $raw_optionset_members} { - # - set msg "Bad options for %caller%. Option $optionset at index [expr {$i-1}] requires a value, but '$flagname' not specified in definition to allow space-separated value." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list badoptionformat $optionset index [expr {$i-1}]] -badarg $optionset -argspecs $argspecs]] $msg - } - } - if {$solo_only} { - #same logic as 'solo' branch below for -type none - if {[tcl::dict::exists $argstate $optionset -typedefaults]} { - set tdflt [tcl::dict::get $argstate $optionset -typedefaults] - } else { - #normal default for a solo is 1 unless overridden by -typedefaults - set tdflt 1 - } - if {[tcl::dict::get $argstate $optionset -multiple]} { - if {$api_opt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $flag_ident $tdflt - } else { - tcl::dict::lappend opts $flag_ident $tdflt - } - if {$api_opt ni $multisreceived} { - lappend multisreceived $api_opt - } - } else { - if {$flag_ident_is_parsekey} { - lappend opts $flag_ident $tdflt - } else { - tcl::dict::set opts $flag_ident $tdflt - } - } - incr vals_remaining_possible -1 - lappend solosreceived $api_opt ;#dups ok - } else { - #check if it was actually a value that looked like a flag - if {$i == $maxidx} { - #if no optvalue following - assume it's a value - #(caller should probably have used -- before it) - #review - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - #flagval comes from next remaining rawarg - set flagval [lindex $remaining_rawargs $i+1] - if {[tcl::dict::get $argstate $optionset -multiple]} { - #don't lappend to default - we need to replace if there is a default - if {$api_opt ni $flagsreceived} { - tcl::dict::set opts $flag_ident [list $flagval] - } else { - tcl::dict::lappend opts $flag_ident $flagval - } - if {$api_opt ni $multisreceived} { - lappend multisreceived $api_opt - } - } else { - #tcl::dict::set opts $flag_ident $flagval - if {$flag_ident_is_parsekey} { - #necessary shimmer - lappend opts $flag_ident $flagval - } else { - tcl::dict::set opts $flag_ident $flagval - } - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - set msg "Bad options for %caller%. No value supplied for last option $optionset at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $optionset index [expr {$i-1}]] -badarg $optionset -argspecs $argspecs]] $msg - } - } - } - } else { - #none / solo - if {[tcl::dict::exists $argstate $optionset -typedefaults]} { - set tdflt [tcl::dict::get $argstate $optionset -typedefaults] - } else { - #normal default for a solo is 1 unless overridden by -typedefaults - set tdflt 1 - } - if {[tcl::dict::get $argstate $optionset -multiple]} { - if {$api_opt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $flag_ident $tdflt - } else { - tcl::dict::lappend opts $flag_ident $tdflt - } - if {$api_opt ni $multisreceived} { - lappend multisreceived $api_opt - } - } else { - #test parse_withdef_parsekey_repeat_ordering {Ensure last flag has precedence} - #tcl::dict::set opts $flag_ident $tdflt - if {$flag_ident_is_parsekey} { - #(shimmer - but required for ordering correctness during override) - lappend opts $flag_ident $tdflt - } else { - tcl::dict::set opts $flag_ident $tdflt - } - } - incr vals_remaining_possible -1 - lappend solosreceived $api_opt ;#dups ok - } - lappend flagsreceived $api_opt ;#dups ok - } else { - #starts with - but unmatched option flag - #comparison to valmin already done above - if {$valmax ne -1 && $remaining_args_including_this <= $valmax} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding valmax valmin - - #even if optany - assume an unknown within the space of possible values is a value - #unmatched option in right position to be considered a value - treat like eopts - #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - if {!([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { - if {$OPT_ANY} { - #exlude argument with whitespace from being a possible option e.g dict - #todo - passthrough of unrecognised --longopt=xxx without looking for following flag-value - set eposn [string first = $a] - if {[string match --* $a] && $eposn > 2} { - #only allow longopt-style = for double leading dash longopts - #--*= $maxidx} { - set msg "Bad options for %caller%. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingoptionvalue $a index [expr {$i-1}]] -badarg $a -argspecs $argspecs]] $msg - #arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a - } - incr vals_remaining_possible -2 - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::exists $argstate $a -typedefaults]} { - set tdflt [tcl::dict::get $argstate $a -typedefaults] - } else { - set tdflt 1 - } - if {[tcl::dict::get $argstate $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a $tdflt - } else { - tcl::dict::lappend opts $a $tdflt - } - if {$a ni $multisreceived} { - lappend multisreceived $a - } - } else { - tcl::dict::set opts $a $tdflt - } - incr vals_remaining_possible -1 - lappend solosreceived $a - } - } - - lappend flagsreceived $undefined_flagsupplied ;#adhoc flag name (if --x=1 -> --x) - } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for %caller%. Unexpected option \"$a\": must be one of: $OPT_NAMES (3)" - } else { - set errmsg "bad options for %caller%. Unexpected option \"$a\": No options defined while @opts -any|-arbitrary false" - } - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list invalidoption $a options $OPT_NAMES] -badarg $a -argspecs $argspecs]] $errmsg - #arg_error $errmsg $argspecs -badarg $optionset - } - } else { - #not a flag/option - set arglist [lrange $remaining_rawargs 0 $i-1] - set post_values [lrange $remaining_rawargs $i end] - break - } - } - - } - #set values [list {*}$pre_values {*}$post_values] - set leaders $pre_values - set values $post_values - } else { - set leaders $pre_values - set values $remaining_rawargs - #set values [list {*}$pre_values {*}$remaining_rawargs] ;#no -flags detected - set arglist [list] - } - #set id [dict get $argspecs id] - #if {$id eq "::if"} { - #puts stderr "::if" - #puts stderr "get_dict--> arglist: $arglist" - #puts stderr "get_dict--> leaders: $leaders" - #puts stderr "get_dict--> values: $values" - #} - - #--------------------------------------- - #Order the received options by the order in which they are *defined* - #EXCEPT that grouped options using same parsekey must be processed in received order - set ordered_opts [dict create] - - #set unaliased_opts [lmap v $OPT_NAMES {string trimright [lindex [split $v |] end] =}] - ##unaliased_opts is list of 'api_opt' (to handle flag aliases of form -a1|-a2|-api_opt) - ## e.g -fg|-foreground - ## e.g -x|--fullname= - ##Resulting unaliased_opts from list {-fg|-foreground -x|--fullname=} should be {-foreground --fullname} - #foreach o $unaliased_opts optset $OPT_NAMES { - # if {[dict exists $opts $o]} { - # dict set ordered_opts $o [dict get $opts $o] - # } elseif {[dict exists $OPT_DEFAULTS $optset]} { - # #JJJ - # set parsekey "" - # if {[tcl::dict::exists $argstate $o -parsekey]} { - # set parsekey [tcl::dict::get $argstate $o -parsekey] - # } - # if {$parsekey eq ""} { - # set parsekey $o - # } - # dict set ordered_opts $parsekey [dict get $OPT_DEFAULTS $optset] - # } - #} - - #puts ">>>>==== $opts" - set seen_pks [list] - #treating opts as list for this loop. - foreach optset $OPT_NAMES { - set parsekey "" - set has_parsekey_override 0 - if {[tcl::dict::exists $argstate $optset -parsekey]} { - set parsekey [tcl::dict::get $argstate $optset -parsekey] - } - if {$parsekey eq ""} { - set has_parsekey_override 0 - #fall back to last element of aliased option e.g -fg|-foreground -> "-foreground" - set parsekey [string trimright [lindex [split $optset |] end] =] - } else { - set has_parsekey_override 1 - } - lappend seen_pks $parsekey - set is_found 0 - set foundkey "" - set foundval "" - #no lsearch -stride avail in 8.6 - foreach {k v} $opts { - if {$k eq $parsekey} { - set foundkey $k - set is_found 1 - set foundval $v - #can be multiple - last match wins - don't 'break' out of foreach - } - } ;#avoiding further dict/list shimmering - #if {[dict exists $opts $parsekey]} { - # set found $parsekey - # set foundval [dict get $opts $parsekey] - #} - if {!$is_found && $parsekey ne $optset} { - #.g we may have in opts things like: -decreasing|-SORTDIRECTION -increasing|-SORTDIRECTION - #(where -SORTDIRECTION was configured as -parsekey) - #last entry must win - #NOTE - do not use dict for here. opts is not strictly a dict - dupe keys will cause wrong ordering - foreach {o v} $opts { - if {[string match *|$parsekey $o]} { - set foundkey $o - set is_found 1 - set foundval $v - #last match wins - don't 'break' out of foreach - } - } - } - if {$is_found} { - dict set ordered_opts $foundkey $foundval - } elseif {[tcl::dict::exists $OPT_DEFAULTS $optset]} { - if {$parsekey ne $optset} { - set tailopt [string trimright [lindex [split $optset |] end] =] - if {$tailopt ne $parsekey} { - #defaults for multiple options sharing a -parsekey value ? review - dict set ordered_opts $tailopt|$parsekey [dict get $OPT_DEFAULTS $optset] - } else { - dict set ordered_opts $parsekey [dict get $OPT_DEFAULTS $optset] - } - } else { - dict set ordered_opts $parsekey [dict get $OPT_DEFAULTS $optset] - } - } - } - - #add in possible arbitrary opts after the defined opts, due to @opts directive flag '-any|-arbitrary true' - #But make sure not to add any repeated parsekey e.g -increasing|-SORT -decreasing|-SORT - #use the seen_pks from the ordered_opts loop above - #keep working with opts only as list here.. - if {[llength $opts] > 2*[dict size $ordered_opts]} { - foreach {o o_val} $opts { - lassign [split $o |] _ parsekey ;#single pipe - 2 elements only | - if {$parsekey ne "" && $parsekey in $seen_pks} { - continue - } - if {![dict exists $ordered_opts $o]} { - dict set ordered_opts $o $o_val - } - } - } - set opts $ordered_opts - #opts is a proper dict now - - #NOTE opts still may contain some entries in non-final form such as -flag|-PARSEKEY - #--------------------------------------- - - - set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set leadername_multiple "" - set leadernames_received [list] - - set num_leaders [llength $leaders] - - #---------------------------------------- - #Establish firm leaders ordering - set leaders_dict [dict create] - foreach lname [lrange $LEADER_NAMES 0 $num_leaders-1] { - dict set leaders_dict $lname {} - } - set leaders_dict [dict merge $leaders_dict $LEADER_DEFAULTS] - #---------------------------------------- - - set argument_clause_typestate [dict create] ;#Track *updated* -type info for argument clauses for those subelements that were fully validated during _get_dict_can_assign_value - - - set start_position $positionalidx - set nameidx 0 - #MAINTENANCE - (*nearly*?) same loop logic as for value - for {set ldridx 0} {$ldridx < [llength $leaders]} {incr ldridx} { - set leadername [lindex $LEADER_NAMES $nameidx] - set ldr [lindex $leaders $ldridx] - if {$leadername ne ""} { - set leadertypelist [tcl::dict::get $argstate $leadername -type] - set leader_clause_size [llength $leadertypelist] - - set assign_d [_get_dict_can_assign_value $ldridx $leaders $nameidx $LEADER_NAMES $leadernames_received $formdict] - set consumed [dict get $assign_d consumed] - set resultlist [dict get $assign_d resultlist] - set newtypelist [dict get $assign_d typelist] - if {[tcl::dict::get $argstate $leadername -optional]} { - if {$consumed == 0} { - puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername leaders:$leaders (111)" - #return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "_get_dict_can_assign_value consumed 0 unexpected 1?" - incr ldridx -1 - set leadername_multiple "" - incr nameidx - continue - } - } else { - #required named arg - if {$consumed == 0} { - if {$leadername ni $leadernames_received} { - #puts stderr "_get_dict_can_assign_value $ldridx $values $nameidx $VAL_NAMES" - set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredleader $leadername ] -argspecs $argspecs]] $msg - } else { - puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername (222)" - #return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "_get_dict_can_assign_value consumed 0 unexpected 2?" - incr ldridx -1 - set leadername_multiple "" - incr nameidx - continue - } - } - } - - if {$leader_clause_size == 1} { - #set clauseval $ldr - set clauseval [lindex $resultlist 0] - } else { - set clauseval $resultlist - incr ldridx [expr {$consumed - 1}] - - #not quite right.. this sets the -type for all clauses - but they should run independently - #e.g if expr {} elseif 2 {script2} elseif 3 then {script3} (where elseif clause defined as "literal(elseif) expr ?literal(then)? script") - #the elseif 2 {script2} will raise an error because the newtypelist from elseif 3 then {script3} overwrote the newtypelist where then was given the type ?omitted-...? - - tcl::dict::set argstate $leadername -type $newtypelist ;#(possible ?omitted-? and ?defaulted-? entries - } - - if {[tcl::dict::get $argstate $leadername -multiple]} { - #if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - # #current stored ldr equals defined default - don't include default in the list we build up - # tcl::dict::set leaders_dict $leadername [list $clauseval] ;#important to treat first element as a list - #} else { - # tcl::dict::lappend leaders_dict $leadername $clauseval - #} - if {$leadername in $leadernames_received} { - tcl::dict::lappend leaders_dict $leadername $clauseval - tcl::dict::lappend argument_clause_typestate $leadername $newtypelist - } else { - tcl::dict::set leaders_dict $leadername [list $clauseval] - tcl::dict::set argument_clause_typestate $leadername [list $newtypelist] - } - set leadername_multiple $leadername - } else { - tcl::dict::set leaders_dict $leadername $clauseval - tcl::dict::set argument_clause_typestate $leadername [list $newtypelist] - set leadername_multiple "" - incr nameidx - } - lappend leadernames_received $leadername - } else { - if {$leadername_multiple ne ""} { - set leadertypelist [tcl::dict::get $argstate $leadername_multiple -type] - if {[llength $leadertypelist] == 1} { - set clauseval $ldr - } else { - set clauseval [list] - incr ldridx -1 - foreach t $leadertypelist { - incr ldridx - if {$ldridx > [llength $leaders]-1} { - set msg "Bad number of leaders for %caller%. Received [llength $clauseval] values ('$clauseval') for '$leadername_multiple', but requires up to [llength $leadertypelist] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $leadertypelist] ] -argspecs $argspecs]] $msg - } - lappend clauseval [lindex $leaders $ldridx] - } - } - tcl::dict::lappend leaders_dict $leadername_multiple $clauseval - #name already seen - but must add to leadernames_received anyway (as with opts and values) - lappend leadernames_received $leadername_multiple - } else { - if {$LEADER_UNNAMED} { - tcl::dict::set leaders_dict $positionalidx $ldr - tcl::dict::set argstate $positionalidx $LEADERSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $LEADER_CHECKS_DEFAULTS - lappend leadernames_received $positionalidx - } else { - set msg "Bad number of leaders for %caller%. Received more leaders than can be assigned to argument names. (set '@leaders -unnamed true' to allow unnamed leaders)" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list toomanyarguments [llength $values] index $positionalidx] -argspecs $argspecs]] $msg - } - } - } - set positionalidx [expr {$start_position + $ldridx + 1}] - } - #----------------------------------------------------- - #satisfy test parse_withdef_leaders_no_phantom_default - #foreach leadername [dict keys $leaders_dict] { - # if {[string is integer -strict $leadername]} { - # #ignore leadername that is a positionalidx - # #review - always trailing - could use break? - # continue - # } - # if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} { - # #remove the name with empty-string default we used to establish fixed order of names - # #The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. - # dict unset leaders_dict $leadername - # } - #} - dict for {leadername _v} $leaders_dict { - if {[string is integer -strict $leadername]} { - #ignore leadername that is a positionalidx - #review - always trailing - could use break? - continue - } - if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} { - #remove the name with empty-string default we used to establish fixed order of names - #The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. - dict unset leaders_dict $leadername - } - } - #----------------------------------------------------- - - - set validx 0 - set valname_multiple "" - set valnames_received [list] - - set num_values [llength $values] - #------------------------------------------ - #Establish firm values ordering - ## Don't set values_dict to VAL_DEFAULTS - or order of values_dict will be intermittently wrong based on whether values have defaults - ## set values_dict $val_defaults - set values_dict [dict create] - foreach valname [lrange $VAL_NAMES 0 $num_values-1] { - #set ALL valnames to lock in positioning - #note - later we need to unset any optional that had no default and was not received (no phantom default) - dict set values_dict $valname {} - } - set values_dict [dict merge $values_dict $VAL_DEFAULTS] - #------------------------------------------ - set nameidx 0 - set start_position $positionalidx - #MAINTENANCE - (*nearly*?) same loop logic as for leaders - for {set validx 0} {$validx < [llength $values]} {incr validx} { - set valname [lindex $VAL_NAMES $nameidx] - set val [lindex $values $validx] - if {$valname ne ""} { - set valtypelist [tcl::dict::get $argstate $valname -type] - set clause_size [llength $valtypelist] ;#common case is clause_size == 1 - - set assign_d [_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES $valnames_received $formdict] - set consumed [dict get $assign_d consumed] - set resultlist [dict get $assign_d resultlist] - set newtypelist [dict get $assign_d typelist] - if {[tcl::dict::get $argstate $valname -optional]} { - if {$consumed == 0} { - #error 333 - puts stderr "get_dict cannot assign val:$val to valname:$valname (333)" - incr validx -1 - set valname_multiple "" - incr nameidx - continue - } - } else { - #required named arg - if {$consumed == 0} { - if {$valname ni $valnames_received} { - #puts stderr "_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES" - set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list missingrequiredvalue $valname ] -argspecs $argspecs]] $msg - } else { - #error 444 - puts stderr "get_dict cannot assign val:$val to valname:$valname (444)" - incr validx -1 - set valname_multiple "" - incr nameidx - continue - } - } - } - #assert can_assign != 0, we have at least one value to assign to clause - - if {$clause_size == 1} { - #set clauseval $val - set clauseval [lindex $resultlist 0] - } else { - #clauseval must contain as many elements as the max length of -types! - #(empty-string/default for optional (?xxx?) clause members) - set clauseval $resultlist - #_get_dict_can_assign has only validated clause-length and literals match - #we assign and leave further validation for main validation loop. - incr validx [expr {$consumed -1}] - if {$validx > [llength $values]-1} { - error "get_dict unreachable" - set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname', but requires up to $clause_size values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength $clause_size ] -argspecs $argspecs]] $msg - } - - #incorrect - we shouldn't update the default. see argument_clause_typestate dict of lists of -type - tcl::dict::set argstate $valname -type $newtypelist ;#(possible ?omitted-? and ?defaulted-? entries - } - - if {[tcl::dict::get $argstate $valname -multiple]} { - #if {[tcl::dict::exists $VAL_DEFAULTS $valname]} { - # #current stored val equals defined default - don't include default in the list we build up - # tcl::dict::set values_dict $valname [list $clauseval] ;#important to treat first element as a list - #} else { - # tcl::dict::lappend values_dict $valname $clauseval - #} - if {$valname in $valnames_received} { - tcl::dict::lappend values_dict $valname $clauseval - tcl::dict::lappend argument_clause_typestate $valname $newtypelist - } else { - tcl::dict::set values_dict $valname [list $clauseval] - tcl::dict::set argument_clause_typestate $valname [list $newtypelist] - } - set valname_multiple $valname - } else { - tcl::dict::set values_dict $valname $clauseval - tcl::dict::set argument_clause_typestate $valname [list $newtypelist] ;#list protect - set valname_multiple "" - incr nameidx - } - lappend valnames_received $valname - } else { - #unnamed - if {$valname_multiple ne ""} { - set valtypelist [tcl::dict::get $argstate $valname_multiple -type] - if {[llength $valname_multiple] == 1} { - set clauseval $val - } else { - set clauseval [list] - incr validx -1 - for {set i 0} {$i < [llength $valtypelist]} {incr i} { - incr validx - if {$validx > [llength $values]-1} { - set msg "Bad number of values for %caller%. Received [llength $clauseval] values for clause '$valname_multiple', but requires [llength $valtypelist] values." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list clausevaluelength [llength $clauseval] clauselength [llength $valtypelist] ] -argspecs $argspecs]] $msg - } - lappend clauseval [lindex $values $validx] - } - } - tcl::dict::lappend values_dict $valname_multiple $clauseval - #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $valname_multiple - } else { - if {$VAL_UNNAMED} { - tcl::dict::set values_dict $positionalidx $val - tcl::dict::set argstate $positionalidx $VALSPEC_DEFAULTS - tcl::dict::set arg_checks $positionalidx $VAL_CHECKS_DEFAULTS - lappend valnames_received $positionalidx - } else { - set msg "Bad number of values for %caller%. Received more values than can be assigned to argument names. (set '@values -unnamed true' to allow unnamed values)" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list toomanyarguments [llength $values] index $positionalidx] -argspecs $argspecs]] $msg - } - } - } - set positionalidx [expr {$start_position + $validx + 1}] - } - #----------------------------------------------------- - #satisfy test parse_withdef_values_no_phantom_default - foreach vname [dict keys $values_dict] { - if {[string is integer -strict $vname]} { - #ignore vname that is a positionalidx - #review - always trailing - could break? - continue - } - if {$vname ni $valnames_received && ![dict exists $VAL_DEFAULTS $vname]} { - #remove the name with empty-string default we used to establish fixed order of names - #The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default. - dict unset values_dict $vname - } - } - #----------------------------------------------------- - #JJJJJJ - #if {[dict size $argument_clause_typestate]} { - # puts ">>>>>[dict get $argspecs id] typestate $argument_clause_typestate" - #} - - if {$leadermax == -1} { - #only check min - if {$num_leaders < $leadermin} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected at least $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } else { - if {$num_leaders < $leadermin || $num_leaders > $leadermax} { - if {$leadermin == $leadermax} { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected exactly $leadermin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of leading values for %caller%. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadingvaluecount $num_leaders min $leadermin max $leadermax] -argspecs $argspecs]] $msg - } - } - } - - if {$valmax == -1} { - #only check min - if {$num_values < $valmin} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected at least $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } else { - if {$num_values < $valmin || $num_values > $valmax} { - if {$valmin == $valmax} { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected exactly $valmin" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } else { - set msg "Bad number of trailing values for %caller%. Got $num_values values. Expected between $valmin and $valmax inclusive" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list trailingvaluecount $num_values min $valmin max $valmax] -argspecs $argspecs]] $msg - } - } - } - - #assertion - opts keys are full-length option names if -any|-arbitrary was false or if the supplied option as a shortname matched one of our defined options - #(and may still contain non-final flag_ident entries such as -increasing|-SORTDIRECTION) - - - #opts explicitly marked as -optional 0 must be present - regardless of -any|-arbitrary (which allows us to ignore additional opts to pass on to next call) - #however - if -any|-arbitrary is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call - #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW - #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. - #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level - #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true - - #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? - #example timing difference: - #struct::set difference {x} {a b} - #normal interp 0.18 u2 vs safe interp 9.4us - #if {[llength [set missing [struct::set difference $OPT_REQUIRED $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" - #} - #if {[llength [set missing [struct::set difference $VAL_REQUIRED $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" - #} - #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us - if {[llength $LEADER_REQUIRED]} { - if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - set msg "Required leader missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list leadermissing $missing received $leadernames_received] -argspecs $argspecs]] $msg - #arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - } - if {[llength $OPT_REQUIRED]} { - set api_opt_required [lmap v $OPT_REQUIRED {lindex [split $v |] end}] - if {[llength [set missing [punklib_ldiff $api_opt_required $flagsreceived]]]} { - set full_missing [dict get $lookup_optset $missing] - set msg "Required option missing for %caller%. missing flags: '$full_missing' are marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list optionmissing $full_missing received $flagsreceived] -argspecs $argspecs]] $msg - #arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs - } - } - if {[llength $VAL_REQUIRED]} { - if {[llength [set missing [punklib_ldiff $VAL_REQUIRED $valnames_received]]]} { - set msg "Required value missing for %caller%. missing values: '$missing' marked with -optional false - so must be present" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list valuemissing $missing received $valnames_received] -argspecs $argspecs]] $msg - #arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - } - - #--------------------------------------------------------------------------------------------- - #maintain order of opts $opts values $values as caller may use lassign. - set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] - if {[llength $receivednames]} { - #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] - set i -1 - set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] - } else { - set received_posns [list] - } - #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) - #(e.g using 'dict exists $received -flag') - # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements - #--------------------------------------------------------------------------------------------- - - - #todo - truncate/summarize values in error messages - - #todo - allow defaults outside of choices/ranges - - #check types,ranges,choices - set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] - #set combined_defaults [tcl::dict::merge $VAL_DEFAULTS $OPT_DEFAULTS] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash - #puts "get_dict>>>>>>>> ---opts_and_values:$opts_and_values" - #puts " >>>>>>> ---lookup_optset :$lookup_optset" - #puts "---argstate:$argstate" - #JJJ argname_or_ident; ident example: -increasing|-SORTOPTION - tcl::dict::for {argname_or_ident value_group} $opts_and_values { - # - #parsekey: key used in resulting leaders opts values dictionaries - # often distinct from the full argname in the ARG_INFO structure - # - if {[string match -* $argname_or_ident]} { - #ident format only applies to options/flags - if {[string first | $argname_or_ident] > -1} { - #flag_ident style (grouped fullname of option with -parsekey) - lassign [split $argname_or_ident |] fullflag parsekey ;#we expect only a single pipe in ident form | - if {[dict exists $lookup_optset $fullflag]} { - set argname [dict get $lookup_optset $fullflag] - #idents should already have correct parsekey - } else { - puts stderr "punk::args::get_dict unable to find $fullflag in $lookup_optset (parsekey:$parsekey) (value_group: $value_group)" - } - } else { - if {[dict exists $lookup_optset $argname_or_ident]} { - #get full option name such as -fg|-foreground from non-alias name such as -foreground - #if "@opts -any|-arbitrary true" - we may have an option that wasn't defined - set argname [dict get $lookup_optset $argname_or_ident] - set pkoverride [Dict_getdef $argstate -parsekey ""] - if {$pkoverride ne ""} { - set parsekey $pkoverride - } else { - #default parsekey: last element in argname without trailing = - set parsekey [string trimright [lindex [split $argname |] end] =] - } - } else { - puts stderr "punk::args::get_dict unable to find $argname_or_ident in $lookup_optset (value_group: $value_group)" - } - } - } else { - set argname $argname_or_ident - set pkoverride [Dict_getdef $argstate -parsekey ""] - if {$pkoverride ne ""} { - set parsekey $pkoverride - } else { - #leader or value of form x|y has no special meaning and forms the parsekey in entirety by default. - set parsekey $argname - } - } - #assert: argname is the key for the relevant argument info in the FORMS//ARG_INFO dict. (here each member available as $argstate) - #argname is usually the full name as specified in the definition: - #e.g -f|-path|--filename= - # (where the parsekey will be by default --filename, possibly overridden by -parsekey value) - #an example argname_or_compound for the above might be: -path|--filename - # where -path is the expanded form of the actual flag used (could have been for example just -p) and --filename is the parsekey - - set thisarg [tcl::dict::get $argstate $argname] - #set thisarg_keys [tcl::dict::keys $thisarg] - set thisarg_checks [tcl::dict::get $arg_checks $argname] - set is_multiple [tcl::dict::get $thisarg -multiple] - set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi] - set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped] - set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi] - set has_default [tcl::dict::exists $thisarg -default] - if {$has_default} { - set defaultval [tcl::dict::get $thisarg -default] - } - set typelist [tcl::dict::get $thisarg -type] - set clause_size [llength $typelist] - set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set validationtransform [tcl::dict::get $thisarg -validationtransform] - - - #JJJJ - #if {$is_multiple} { - # set vlist $value_group - #} else { - # set vlist [list $value_group] - #} - ##JJJJ - #if {$clause_size == 1} { - # set vlist [list $vlist] - #} - - - #JJ 2025-07-25 - set vlist [list] - #vlist is a list of clauses. Each clause is a list of values of length $clause_size. - #The common case is clause_size 1 - but as we need to treat each clause as a list during validation - we need to list protect the clause when clause_size == 1. - if {$is_multiple} { - if {$clause_size == 1} { - foreach c $value_group { - lappend vlist [list $c] - } - } else { - set vlist $value_group - } - } else { - if {$clause_size ==1} { - set vlist [list [list $value_group]] - } else { - set vlist [list $value_group] - } - } - set vlist_typelist [list] - if {[dict exists $argument_clause_typestate $argname]} { - #lookup saved newtypelist (argument_clause_typelist) from can_assign_value result where some optionals were given type ?omitted-? or ?defaulted-? - # args.test: parse_withdef_value_clause_missing_optional_multiple - set vlist_typelist [dict get $argument_clause_typestate $argname] - } else { - foreach v $vlist { - lappend vlist_typelist $typelist - } - } - - - - set vlist_original $vlist ;#retain for possible final strip_ansi - - #review - validationtransform - if {$is_validate_ansistripped} { - #validate_ansistripped 1 - package require punk::ansi - set vlist_check [list] - foreach clause_value $vlist { - #lappend vlist_check [punk::ansi::ansistrip $clause_value] - set stripped [list] - foreach element $clause_value { - lappend stripped [punk::ansi::ansistrip $element] - } - lappend vlist_check $stripped - } - } else { - #validate_ansistripped 0 - set vlist_check $vlist - } - - switch -- [Dict_getdef $thisarg -ARGTYPE unknown] { - leader { - set dname leaders_dict - set argclass "Leading argument" - } - option { - set dname opts - set argclass Option - } - value { - set dname values_dict - set argclass "Trailing argument" - } - default { - set dname "_unknown_" ;#NA - set argclass "Unknown argument" - } - } - set vlist_validate [list] - set vlist_check_validate [list] - set vlist_typelist_validate [list] - #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestricted 0 where some selections match and others don't) - if {$parsekey in $receivednames && $has_choices} { - #-choices must also work with -multiple - #todo -choicelabels - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] - set choiceprefixreservelist [Dict_getdef $thisarg -choiceprefixreservelist {}] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set choicemultiple [tcl::dict::get $thisarg -choicemultiple] - if {[string is integer -strict $choicemultiple]} { - set choicemultiple [list $choicemultiple $choicemultiple] - } - lassign $choicemultiple choicemultiple_min choicemultiple_max - set nocase [tcl::dict::get $thisarg -nocase] - set choices [Dict_getdef $thisarg -choices {}] - set choicegroups [Dict_getdef $thisarg -choicegroups {}] - set allchoices $choices - if {[dict size $choicegroups]} { - dict for {groupname groupmembers} $choicegroups { - lappend allchoices {*}$groupmembers - } - } - #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups - #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - - - set clause_index -1 ;# - #leaders_dict/opts/values_dict $argname member has been populated with the actual entered choices - which might be prefixes - #assert llength $vlist == llength [dict get $dname $argname] - # (unless there was a default and the option wasn't specified) - #J2 - #set vlist_validate [list] - #set vlist_check_validate [list] - foreach clause $vlist clause_check $vlist_check clause_typelist $vlist_typelist { - incr clause_index - set element_index -1 ;#element within clause - usually clause size is only 1 - foreach e $clause e_check $clause_check { - incr element_index - set allchoices_in_list 0 - if {$choicemultiple_max > 1 || $choicemultiple_max == -1} { - #vlist and vlist_check can be list of lists if -multiple and -choicemultiple - #each e represents 0 or more choice selections - set c_list $e - set c_check_list $e_check - #todo? check if entire list matches default? - } else { - #only one choice at a time - ensure single entry in c_list c_check_list - set c_list [list $e] - set c_check_list [list $e_check] - } - - - #----------------------------------- - #fast fail on the wrong number of choices - if {[llength $c_list] < $choicemultiple_min} { - set msg "$argclass $argname for %caller% requires at least $choicemultiple_min choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { - set msg "$argclass $argname for %caller% requires at most $choicemultiple_max choices. Received [llength $c_list] choices." - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } - #----------------------------------- - - set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list - foreach c $c_list c_check $c_check_list { - if {$nocase} { - set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $allchoices] - #Don't lcase the denylist - even in nocase mode! - #set choiceprefixdenylist [tcl::string::tolower $choiceprefixdenylist] - set v_test [tcl::string::tolower $c_check] - } else { - set casemsg " (case sensitive)" - set choices_test $allchoices - set v_test $c_check - } - set choice_in_list 0 - set matches_default [expr {$has_default && $c eq $defaultval}] ;# defaultval when -choicemultiple could be a list? - if {!$matches_default} { - if {$choiceprefix} { - #can we handle empty string as a choice? It should just work - REVIEW/test - set choice_exact_match 0 - if {$c_check in $allchoices} { - #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check - set choice_in_list 1 - set choice_exact_match 1 - } elseif {$v_test in $choices_test} { - #assert - if we're here, nocase must be true - #we know choice is present as full-length match except for case - #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below - #review - foreach avail [lsort -unique $allchoices] { - if {[string match -nocase $c $avail]} { - set chosen $avail - } - } - #assert chosen will always get set - set choice_in_list 1 - } else { - #puts ">>>> choiceprefixreservelist: $choiceprefixreservelist" - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. - #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. - #in this block we can treat empty result from prefix match as a non-match - if {$nocase} { - #nocase implies that our entered value doesn't have to match case of choices - - #but we would still like to select the best match if there are case-dups. - #e.g arg -choices {delete Delete} -nocase 1 -choiceprefixdenylist delete - # selecting Del will find Delete, del will match delete (and raise error) - # but DEL will also match delete rather than Delete - so again an error is raised. - #This is counterintuitive with -nocase - #This is probably such an edge case that best served with documentation as a feature-not-bug - #Rationale being that in a nocase situation it's arbitrary/counterintuitive to consider DEL, or DeL a better match for Delete than delete? - #The choice of the user to use -choiceprefixdenylist along with case-dups is the issue. - - set bestmatch [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] - if {$bestmatch eq "" || $bestmatch in $choiceprefixreservelist} { - set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $choices_test] {*}$choiceprefixreservelist] $v_test] - #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing - set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] - } else { - set chosen $bestmatch - set choice_in_list 1 - } - } else { - set chosen [tcl::prefix::match -error "" [list {*}[lsort -unique $allchoices] {*}$choiceprefixreservelist] $c_check] - if {$chosen eq "" || $chosen in $choiceprefixreservelist} { - set choice_in_list 0 - } else { - set choice_in_list 1 - } - } - #override choice_in_list if in deny list - #don't allow prefixing for elements from -choiceprefixdenylist - #we still use all elements to calculate the prefixes though - #review - case difference edge cases in choiceprefixdenylist !todo - if {$chosen in $choiceprefixdenylist} { - set choice_in_list 0 - set chosen "" - } - } - - #override the optimistic existing val - #our existing values in $dname are not list-protected - so we need to check clause_size - if {$choice_in_list && !$choice_exact_match} { - set existing [tcl::dict::get [set $dname] $argname_or_ident] - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - #single choice allowed per clause-member - if {$is_multiple} { - if {$clause_size == 1} { - #no list wrapping of single element in $dname dict - so don't index into it with element_index - lset existing $element_index $chosen - } else { - lset existing $clause_index $element_index $chosen - } - tcl::dict::set $dname $argname_or_ident $existing - } else { - #test: choice_multielement_clause - lset existing $element_index $chosen - tcl::dict::set $dname $argname_or_ident $existing - } - } else { - if {$is_multiple} { - #puts ">>> existing $existing $choice_idx" - if {$clause_size == 1} { - #no list wrapping of single element in $dname dict - so don't index into it with element_index - lset existing $clause_index $choice_idx $chosen - } else { - lset existing $clause_index $element_index $choice_idx $chosen - } - tcl::dict::set $dname $argname_or_ident $existing - } else { - lset existing $element_index $choice_idx $chosen - tcl::dict::set $dname $argname_or_ident $existing - } - } - } - } else { - #value as stored in $dname is ok - set choice_in_list [expr {$v_test in $choices_test}] - } - } - - if {!$choice_in_list && !$matches_default} { - if {!$choicerestricted} { - #if {$is_multiple} { - # set existing [tcl::dict::get [set $dname] $argname] - # lset existing $clause_index $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - #JJJ - #lappend vlist_validate $c - #lappend vlist_check_validate $c_check - } else { - #unhappy path - if {$choiceprefix} { - set prefixmsg " (or a unique prefix of a value)" - } else { - set prefixmsg "" - } - #review: $c vs $c_check for -badval? - set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg - #arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c'" $argspecs -badarg $argname - } - } else { - #choice is in list or matches default - no validation for this specific element in the clause - lset clause_typelist $element_index any - } - incr choice_idx - } - - } ;#end foreach e in clause - #jjj 2025-07-16 - #if not all clause_typelist are 'any' - if {[lsearch -not $clause_typelist any] > -1} { - #at least one element still needs validation - lappend vlist_validate $clause - lappend vlist_check_validate $clause_check - lappend vlist_typelist_validate $clause_typelist - } - - - } ;#end foreach clause in vlist - - #reduce our vlist and vlist_check lists by removing choice matches as they need to be passed through without validation - #we also have retained any that match defaultval - whether or not it was in -choices or -choicegroups - set vlist $vlist_validate - set vlist_check $vlist_check_validate - set vlist_typelist $vlist_typelist_validate - } - - #todo - don't add to validation lists if not in receivednames - #if we have an optionset such as "-f|-x|-etc"; the parsekey is -etc (unless it was overridden by -parsekey in definition) - if {$parsekey ni $receivednames} { - set vlist [list] - set vlist_check_validate [list] - } else { - if {[llength $vlist] && $has_default} { - #defaultval here is a value for the entire clause. (clause usually length 1) - #J2 - #set vlist_validate [list] - #set vlist_check_validate [list] - set tp [dict get $thisarg -type] - set clause_size [llength $tp] - foreach clause_value $vlist clause_check $vlist_check clause_typelist $vlist_typelist { - #JJJJ - #REVIEW!!! we're inadvertently adding back in things that may have already been decided in choicelist loop as not requiring validation? - if {$clause_value ni $vlist_validate} { - if {$clause_size ==1} { - #for -choicemultiple with default that could be a list use 'ni' - #?? review! - if {[lindex $clause_check 0] ne $defaultval} { - lappend vlist_validate $clause_value - lappend vlist_check_validate $clause_check - lappend vlist_typelist_validate $clause_typelist - } - } else { - if {$clause_check ne $defaultval} { - lappend vlist_validate $clause_value - lappend vlist_check_validate $clause_check - lappend vlist_typelist_validate $clause_typelist - } - } - } - #if {[llength $tp] == 1} { - # if {$clause_value ni $vlist_validate} { - # #for -choicemultiple with default that could be a list use 'ni' - # #?? review! - # if {[lindex $clause_check 0] ne $defaultval} { - # lappend vlist_validate $clause_value - # lappend vlist_check_validate $clause_check - # } - # } - #} else { - # if {$clause_value ni $vlist_validate} { - # if {$clause_check ne $defaultval} { - # lappend vlist_validate $clause_value - # lappend vlist_check_validate $clause_check - # } - # } - #} - #Todo? - #else ??? - } - set vlist $vlist_validate - set vlist_check $vlist_check_validate - set vlist_typelist $vlist_typelist_validate - } - } - - #is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups - #assert: our vlist & vlist_check lists have been reduced to remove those - if {[llength $vlist] && !$is_allow_ansi} { - #allow_ansi 0 - package require punk::ansi - #do not run ta::detect on a list - foreach clause_value $vlist { - foreach e $clause_value { - if {[punk::ansi::ta::detect $e]} { - set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'" - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg - } - } - } - } - #puts "argname:$argname v:$v is_default:$is_default" - #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value - #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. - #arguments that are at their default are not subject to type and other checks - - #don't validate defaults or choices that matched - #puts "---> opts_and_values: $opts_and_values" - #puts "===> argname: $argname is_default: $is_default is_choice: $is_choice" - #if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {} - - #our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups - #assert [llength $vlist] == [llength $vlist_check] - if {[llength $vlist]} { - #$t = clause column - - #for {set clausecolumn 0} {$clausecolumn < [llength $typelist]} {incr clausecolumn} {} - set clausecolumn -1 - foreach typespec $typelist { - incr clausecolumn - if {[dict exists $thisarg -typedefaults]} { - set tds [dict get $thisarg -typedefaults] - if {[lindex $vlist $clausecolumn] eq [lindex $tds $clausecolumn]} { - continue - } - } - - set type_expression [string trim $typespec ?] - if {$type_expression in {any none}} { - continue - } - #puts "$argname - switch on type_expression: $type_expression v:[lindex $vlist $clausecolumn]" - #set typespec [lindex $typelist $clausecolumn] - #todo - handle type-alternates e.g -type char|double - #------------------------------------------------------------------------------------ - #_check_clausecolumn argname argclass thisarg thisarg_checks column default_type_expression list_of_clauses list_of_clauses_check list_of_clauses_typelist - _check_clausecolumn $argname $argclass $thisarg $thisarg_checks $clausecolumn $type_expression $vlist $vlist_check $vlist_typelist $argspecs - #------------------------------------------------------------------------------------ - - - #todo - pass validation if matches an entry in -typedefaults - #has_typedefault? - #set typedefault [lindex $typedefaults $clausecolumn] - - - } - - - } - - if {$is_strip_ansi} { - set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach - if {[tcl::dict::get $thisarg -multiple]} { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname_or_ident $stripped_list - } - option { - tcl::dict::set opts $argname_or_ident $stripped_list - } - value { - tcl::dict::set values_dict $argname_or_ident $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0] - } - value { - tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0] - } - } - } - } - } - - set finalopts [dict create] - dict for {o v} $opts { - if {[string first | $o] > -1} { - #set parsekey [lindex [split $o |] end] - dict set finalopts [lindex [split $o |] end] $v - } else { - dict set finalopts $o $v - } - } - return [tcl::dict::create leaders $leaders_dict opts $finalopts values $values_dict received $received_posns solos $solosreceived multis $multisreceived] - } - - lappend PUNKARGS [list { - @id -id ::punk::args::forms - @cmd -name punk::args::forms\ - -summary\ - "List command forms."\ - -help\ - "Return names for each form of a command identified by 'id'. - Most commands are single-form and will only return the name '_default'." - @leaders -min 0 -max 0 - @opts - @values -min 1 -max 1 - id -multiple 0 -optional 0 -help\ - "Exact id of command" - }] - proc forms {id} { - set spec [get_spec $id] - if {[dict size $spec]} { - return [dict get $spec form_names] - } else { - return [list] - } - } - - - lappend PUNKARGS [list { - @id -id ::punk::args::eg - @cmd -name punk::args::eg\ - -summary\ - "Command examples."\ - -help\ - "Return command examples from -help in @examples - directive of a command definition." - @values -min 1 -max -1 - cmditem -multiple 1 -optional 0 - }] - proc eg {args} { - set argd [punk::args::parse $args withid ::punk::args::eg] - lassign [dict values $argd] leaders opts values received - set cmditems [dict get $values cmditem] - set id [lindex $cmditems 0] - set cmdargs [lrange $cmditems 1 end] - - set spec [get_spec $id] - if {$spec eq ""} { - return - } - return [dict get $spec examples_info -help] - } - - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis - @cmd -name punk::args::synopsis\ - -summary\ - "Command synopsis"\ - -help\ - "Return synopsis for each form of a command - on separate lines. - If -form is given, supply only - the synopsis for that form. - " - @opts - -noheader -type none - -form -type string -default * - -return -type string -default full -choices {full summary dict} - @values -min 1 -max -1 - cmditem -multiple 1 -optional 0 - }] - proc synopsis {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis] - - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - if {$has_punkansi} { - set I [punk::ansi::a+ italic] - set NI [punk::ansi::a+ noitalic] - #for inner question marks marking optional type - set IS [punk::ansi::a+ italic strike] - set NIS [punk::ansi::a+ noitalic nostrike] - #set RST [punk::ansi::a] - set RST "\x1b\[m" - } else { - set I "" - set NI "" - set IS "" - set NIS "" - set RST "" - } - - ##set form * - ##if {[lindex $args 0] eq "-form"} { - ## set arglist [lrange $args 2 end] - ## set form [lindex $args 1] - ##} else { - ## set arglist $args - ##} - ##if {[llength $arglist] == 0} { - ## error "punk::args::synopsis expected command id possibly with trailing subcommands/args" - ##} - ##set id [lindex $arglist 0] - ##set cmdargs [lrange $arglist 1 end] - - lassign [dict values $argd] leaders opts values received - set form [dict get $opts -form] - set opt_return [dict get $opts -return] - set cmditems [dict get $values cmditem] - set id [lindex $cmditems 0] - set cmdargs [lrange $cmditems 1 end] - - - set spec [get_spec $id] - if {$spec eq ""} { - return - } - set form_names [dict get $spec form_names] - if {$form ne "*"} { - if {[string is integer -strict $form]} { - set f [lindex $form_names $form] - if {$f ne ""} { - set form_names [list $f] - } else { - set form_names [list] - } - } else { - if {$form in $form_names} { - set form_names [list $form] - } else { - set form_names [list] - } - } - } - - set SYND [dict create] - dict set SYND cmd_info [dict get $spec cmd_info] - #leading "# " required (punk::ns::synopsis will pass through) - if {![dict exists $received -noheader]} { - set syn "# [Dict_getdef $spec cmd_info -summary ""]\n" - } - #todo - -multiple etc - foreach f $form_names { - set SYNLIST [list] - dict set SYND FORMS $f [list] - append syn "$id" - set forminfo [dict get $spec FORMS $f] - #foreach argname [dict get $forminfo LEADER_NAMES] { - # set arginfo [dict get $forminfo ARG_INFO $argname] - # set ARGD [dict create argname $argname class leader] - # if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display [lindex [dict get $arginfo -choices] 0] - # } elseif {[dict get $arginfo -type] eq "literal"} { - # set display $argname - # } else { - # set display $I$argname$RST - # } - # if {[dict get $arginfo -optional]} { - # append syn " ?$display?" - # } else { - # append syn " $display" - # } - # dict set ARGD type [dict get $arginfo -type] - # dict set ARGD optional [dict get $arginfo -optional] - # dict set ARGD display $display - # dict lappend SYND $f $ARGD - #} - set FORMARGS [list] - foreach argname [dict get $forminfo LEADER_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set typelist [dict get $arginfo -type] - if {[llength $typelist] == 1} { - set tp [lindex $typelist 0] - set ts [Dict_getdef $arginfo -typesynopsis ""] - if {$ts ne ""} { - #set arg_display [dict get $arginfo -typesynopsis] - set clause $ts - } else { - #set arg_display $argname - set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) - set type_alternatives [_split_type_expression $tp] - foreach tp_alternative $type_alternatives { - set firstword [lindex $tp_alternative 0] - switch -exact -- $firstword { - literal { - set match [lindex $tp_alternative 1] - lappend alternates $match - } - literalprefix { - #todo - trie styling on prefix calc - set match [lindex $tp_alternative 1] - lappend alternates $match - } - stringstartswith { - set match [lindex $tp_alternative 1] - lappend alternates $match* - } - stringendswith { - set match [lindex $tp_alternative 1] - lappend alternates *$match - } - default { - lappend alternates $I$argname$NI - } - } - - #if {$tp_alternative eq "literal"} { - # lappend alternates [lindex $argname end] - #} elseif {[string match literal(*) $tp_alternative]} { - # set match [string range $tp_alternative 8 end-1] - # lappend alternates $match - #} elseif {[string match literalprefix(*) $tp_alternative]} { - # set match [string range $tp_alternative 14 end-1] - # lappend alternates $match - #} else { - # lappend alternates $I$argname$NI - #} - } - #remove dupes - but keep order (e.g of dupes -type string|int when no -typesynopsis was specified) - #todo - trie prefixes display - set alternates [punk::args::lib::lunique $alternates] - set clause [join $alternates |] - } - } else { - set n [expr {[llength $typelist]-1}] - set name_tail [lrange $argname end-$n end];#if there are enough tail words in the argname to match -types - set clause "" - set ts [Dict_getdef $arginfo -typesynopsis ""] - if {$ts ne ""} { - set tp_displaylist $ts - } else { - set tp_displaylist [lrepeat [llength $typelist] ""] - } - - foreach typespec $typelist td $tp_displaylist elementname $name_tail { - #elementname will commonly be empty - if {[string match {\?*\?} $typespec]} { - set tp [string range $typespec 1 end-1] - set member_optional 1 - } else { - set tp $typespec - set member_optional 0 - } - if {$tp eq "literal"} { - set c $elementname - } elseif {[string match literal(*) $tp]} { - set match [string range $tp 8 end-1] - set c $match - } else { - if {$td eq ""} { - set c $I$tp$NI - } else { - set c $td - } - } - if {$member_optional} { - append clause " " "(?$c?)" - } else { - append clause " " $c - } - } - set clause [string trimleft $clause] - } - - set ARGD [dict create argname $argname class leader] - if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { - if {[dict get $arginfo -multiple]} { - #set display "?$I$argname$NI?..." - set display "?$clause?..." - } else { - set display "?$clause?" - #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display "?[lindex [dict get $arginfo -choices] 0]?" - #} elseif {[dict get $arginfo -type] eq "literal"} { - # set display "?$argname?" - #} else { - # set display "?$I$argname$NI?" - #} - } - } else { - if {[dict get $arginfo -multiple]} { - #set display "$I$argname$NI ?$I$argname$NI?..." - set display "$clause ?$clause?..." - } else { - set display $clause - #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display "[lindex [dict get $arginfo -choices] 0]" - #} elseif {[dict get $arginfo -type] eq "literal"} { - # set display $argname - #} else { - # set display "$I$argname$NI" - #} - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - - #dict lappend SYND $f $ARGD - lappend FORMARGS $ARGD - } - foreach argname [dict get $forminfo OPT_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set ARGD [dict create argname $argname class option] - set tp [dict get $arginfo -type] - if {$tp eq "none"} { - #assert - argname may have aliases delimited by | - but no aliases end with = - #(disallowed in punk::args::define) - set argdisplay $argname - } else { - #assert [llength $tp] == 1 (multiple values for flag unspported in punk::args::define) - if {[string match {\?*\?} $tp]} { - set tp [string range $tp 1 end-1] - set value_is_optional true - } else { - set value_is_optional false - } - - - set ts [Dict_getdef $arginfo -typesynopsis ""] - if {$ts ne ""} { - set tp_display $ts - #user may or may not have remembered to match the typesynopsis with the optionality by wrapping with ? - #review - if user wrapped with ?*? and also leading/trailing ANSI - we won't properly strip - #todo - enforce no wrapping '?*?' in define for -typesynopsis? - set tp_display [string trim $tp_display ?] - } else { - - set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) - foreach tp_alternative [split $tp |] { - #-type literal not valid for opt - review - if {[string match literal(*) $tp_alternative]} { - set match [string range $tp_alternative 8 end-1] - lappend alternates $match - } elseif {[string match literalprefix(*) $tp_alternative]} { - set match [string range $tp_alternative 14 end-1] - lappend alternates $match - } else { - lappend alternates <$I$tp_alternative$NI> - } - } - #todo - trie prefixes display? - set alternates [punk::args::lib::lunique $alternates] - set tp_display [join $alternates |] - } - if {[string first | $tp_display] >=0} { - #need to bracket alternate-types to distinguish pipes delimiting flag aliases - set tp_display "($tp_display)" - } - set argdisplay "" - foreach aliasflag [split $argname |] { - if {[string match --* $aliasflag]} { - if {[string index $aliasflag end] eq "="} { - set alias [string range $aliasflag 0 end-1] - if {$value_is_optional} { - append argdisplay "$alias$IS?$NIS=$tp_display$IS?$NIS|" - } else { - append argdisplay "$alias=$tp_display|" - } - } else { - if {$value_is_optional} { - append argdisplay "$aliasflag $IS?$NIS$tp_display$IS?$NIS|" - } else { - append argdisplay "$aliasflag $tp_display|" - } - } - } else { - if {$value_is_optional} { - #single dash flag can't accept optional value - append argdisplay "$aliasflag|" - } else { - append argdisplay "$aliasflag $tp_display|" - } - } - } - set argdisplay [string trimright $argdisplay |] - } - - if {[dict get $arginfo -optional]} { - if {[dict get $arginfo -multiple]} { - set display "?$argdisplay?..." - } else { - set display "?$argdisplay?" - } - } else { - if {[dict get $arginfo -multiple]} { - set display "$argdisplay ?$argdisplay?..." - } else { - set display $argdisplay - } - } - - #if {[string index $argname end] eq "="} { - # set __ "" - #} else { - # set __ " " - #} - #if {[dict get $arginfo -optional]} { - # if {[dict get $arginfo -multiple]} { - # if {$tp eq "none"} { - # set display "?$argname?..." - # } else { - # set display "?$argname$__$tp_display?..." - # } - # } else { - # if {$tp eq "none"} { - # set display "?$argname?" - # } else { - # set display "?$argname$__$tp_display?" - # } - # } - #} else { - # if {[dict get $arginfo -multiple]} { - # if {$tp eq "none"} { - # set display "$argname ?$argname...?" - # } else { - # set display "$argname$__$tp_display ?$argname$__$tp_display?..." - # } - # } else { - # if {$tp eq "none"} { - # set display $argname - # } else { - # set display "$argname$__$tp_display" - # } - # } - #} - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - #dict lappend SYND $f $ARGD - lappend FORMARGS $ARGD - } - foreach argname [dict get $forminfo VAL_NAMES] { - set arginfo [dict get $forminfo ARG_INFO $argname] - set typelist [dict get $arginfo -type] - if {[llength $typelist] == 1} { - set tp [lindex $typelist 0] - set ts [Dict_getdef $arginfo -typesynopsis ""] - if {$ts ne ""} { - #set arg_display [dict get $arginfo -typesynopsis] - set clause $ts - } else { - #set arg_display $argname - set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first) - foreach tp_alternative [split $tp |] { - if {$tp_alternative eq "literal"} { - lappend alternates [lindex $argname end] - } elseif {[string match literal(*) $tp_alternative]} { - set match [string range $tp_alternative 8 end-1] - lappend alternates $match - } elseif {[string match literalprefix(*) $tp_alternative]} { - set match [string range $tp_alternative 14 end-1] - lappend alternates $match - } else { - lappend alternates $I$argname$NI - } - } - #remove dupes - but keep order (e.g of dupes -type string|int when no -typesynopsis was specified) - #todo - trie prefixes display - set alternates [punk::args::lib::lunique $alternates] - set clause [join $alternates |] - } - } else { - set n [expr {[llength $typelist]-1}] - set name_tail [lrange $argname end-$n end];#if there are enough tail words in the argname to match -types - set clause "" - set ts [Dict_getdef $arginfo -typesynopsis ""] - if {$ts ne ""} { - set tp_displaylist $ts - } else { - set tp_displaylist [lrepeat [llength $typelist] ""] - } - - foreach typespec $typelist td $tp_displaylist elementname $name_tail { - #elementname will commonly be empty - if {[string match {\?*\?} $typespec]} { - set tp [string range $typespec 1 end-1] - set member_optional 1 - } else { - set tp $typespec - set member_optional 0 - } - #handle alternate-types e.g literal(text)|literal(binary) - set alternates [list] - foreach tp_alternative [split $tp |] { - if {$tp_alternative eq "literal"} { - lappend alternates $elementname - } elseif {[string match literal(*) $tp_alternative]} { - set match [string range $tp_alternative 8 end-1] - lappend alternates $match - } elseif {[string match literalprefix(*) $tp_alternative]} { - set match [string range $tp_alternative 14 end-1] - lappend alternates $match - } else { - if {$td eq ""} { - lappend alternates $I$tp$NI - } else { - lappend alternates $td - } - } - } - set alternates [punk::args::lib::lunique $alternates] - set c [join $alternates |] - if {$member_optional} { - append clause " " "(?$c?)" - } else { - append clause " " $c - } - } - set clause [string trimleft $clause] - } - - set ARGD [dict create argname $argname class value] - if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} { - if {[dict get $arginfo -multiple]} { - #set display "?$I$argname$NI?..." - set display "?$clause?..." - } else { - set display "?$clause?" - #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display "?[lindex [dict get $arginfo -choices] 0]?" - #} elseif {[dict get $arginfo -type] eq "literal"} { - # set display "?$argname?" - #} else { - # set display "?$I$argname$NI?" - #} - } - } else { - if {[dict get $arginfo -multiple]} { - #set display "$I$argname$NI ?$I$argname$NI?..." - set display "$clause ?$clause?..." - } else { - set display $clause - #if {[dict exists $arginfo -choices] && [llength [dict get $arginfo -choices]] == 1} { - # set display "[lindex [dict get $arginfo -choices] 0]" - #} elseif {[dict get $arginfo -type] eq "literal"} { - # set display $argname - #} else { - # set display "$I$argname$NI" - #} - } - } - append syn " $display" - dict set ARGD type [dict get $arginfo -type] - dict set ARGD optional [dict get $arginfo -optional] - dict set ARGD display $display - #dict lappend SYND $f $ARGD - lappend FORMARGS $ARGD - } - append syn \n - dict set SYND FORMS $f $FORMARGS - } - switch -- $opt_return { - full { - return [string trim $syn \n] - } - summary { - set summary "" - set FORMS [dict get $SYND FORMS] - dict for {form arglist} $FORMS { - append summary $id - set class_state leader - set option_count 0 - set value_count 0 - foreach ainfo $arglist { - switch -- [dict get $ainfo class] { - leader { - append summary " [dict get $ainfo display]" - } - option { - incr option_count - } - value { - incr value_count - if {$class_state ne "value"} { - if {$option_count > 0} { - append summary " ?options ($option_count defined)?" - } - set class_state value - } - append summary " [dict get $ainfo display]" - } - } - } - if {$value_count == 0 && $option_count > 0} { - append summary " ?options ($option_count defined)?" - } - append summary \n - } - set summary [string trim $summary \n] - return $summary - } - dict { - return $SYND - } - } - } - - - lappend PUNKARGS [list { - @id -id ::punk::args::synopsis_summary - @cmd -name punk::args::synopsis_summary -help\ - "Reduce the width of a synopsis string - by coalescing options to ?options?... - synopsis string may be arbitrarily marked - up with ANSI codes." - @opts - @values -min 1 -max -1 - synopsis -multiple 0 -optional 0 - }] - proc synopsis_summary {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] - set synopsis [dict get $argd values synopsis] - set summary "" - foreach sline [split $synopsis \n] { - set sline [regsub -all {\s+} $sline " "] ;#normalize to single spacing only - review - set in_opt 0 - set line_out "" - set codestack [list] - set parts [punk::ansi::ta::split_codes_single $sline] - #basic - foreach {pt code} $parts { - set charlist [split $pt ""] - for {set i 0} {$i < [llength $charlist]} {incr i} { - set c [lindex $charlist $i] - - switch -- $c { - ? { - if {!$in_opt} { - set in_opt 1 - } else { - - } - } - " " { - if {!$in_opt} { - append line_out " " - } else { - set in_opt - } - } - default { - if {!$in_opt} { - append line_out $c - } - } - } - } - if {$code ne ""} { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } else { - #? ignore other ANSI codes? - } - } - } - if {[string match -* $plain_s] || [string match ?- $plain_s]} { - } - } - return $summary - } - - lappend PUNKARGS [list { - @id -id ::punk::args::TEST - @opts -optional 0 - -o1 -default 111 -help "opt 1 mandatory" - @opts -optional 1 - -o2 -default 222 -help "opt 2 optional" - @values -min 0 -max 1 - v -help\ - "v1 optional" - }] - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::lib { - variable PUNKARGS - tcl::namespace::export * - tcl::namespace::path [list [tcl::namespace::parent]] - #*** !doctools - #[subsection {Namespace punk::args::lib}] - #[para] Secondary functions that are part of the API - #[list_begin definitions] - - #tcl86 compat for string is dict - but without -strict or -failindex options - if {[catch {string is dict {}} errM]} { - proc string_is_dict {args} { - #ignore opts - set str [lindex $args end] - if {[catch {llength $str} len]} { - return 0 - } - if {$len % 2 == 0} { - return 1 - } - return 0 - } - } else { - proc string_is_dict {args} { - string is dict {*}$args - } - } - - - #proc utility1 {p1 args} { - # #*** !doctools - # #[call lib::[fun utility1] [arg p1] [opt {option value...}]] - # #[para]Description of utility1 - # return 1 - #} - - proc flatzip {l1 l2} { - concat {*}[lmap a $l1 b $l2 {list $a $b}] - } - - if {[info commands lseq] ne ""} { - #tcl 8.7+ lseq significantly faster, especially for larger ranges - #The internal rep can be an 'arithseries' with no string representation - proc zero_based_posns {count} { - if {$count < 1} {return} - lseq 0 $count-1 - } - } else { - proc zero_based_posns {count} { - if {$count < 1} {return} - lsearch -all [lrepeat $count 0] * - } - } - - #return list of single column-width marks - possibly with ansi - proc choiceinfo_marks {choice choiceinfodict} { - set marks [list] - if {[dict exists $choiceinfodict $choice]} { - set cinfo [dict get $choiceinfodict $choice] - foreach info $cinfo { - if {[lindex $info 0] eq "doctype"} { - switch -- [lindex $info 1] { - punkargs { - lappend marks [punk::ns::Cmark punkargs brightgreen] - } - ensemble { - lappend marks [punk::ns::Cmark ensemble brightyellow] - } - oo { - lappend marks [punk::ns::Cmark oo brightcyan] - } - ooc { - lappend marks [punk::ns::Cmark ooc cyan] - } - ooo { - lappend marks [punk::ns::Cmark ooo cyan] - } - native { - lappend marks [punk::ns::Cmark native] - } - unknown { - lappend marks [punk::ns::Cmark unknown brightred] - } - } - } - } - } - return $marks - } - - - #experiment with equiv of js template literals with ${expression} in templates - #e.g tstr {This is the value of x in calling scope ${$x} !} - #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} - #e.g tstr -allowcommands {This is the value of [lindex $x -1] in calling scope ${[lindex [set x] 0]} !} - lappend PUNKARGS [list { - @id -id ::punk::args::lib::tstr - @cmd -name punk::args::lib::tstr\ - -summary\ - "Templating with \$\{$varName\}"\ - -help\ - "A rough equivalent of js template literals - - Substitutions: - \$\{$varName\} - \$\{[myCommand]\} - (when -allowcommands flag is given)" - -allowcommands -default 0 -type none -help\ - "If -allowcommands is present, placeholder can contain commands - e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" - -undent -default 1 -type boolean -help\ - "undent/dedent the template lines. - The longest common prefix of whitespace is removed" - -indent -default "" -type string -help\ - "String with which to indent the template - prior to substitution. - If -undent is enabled, that is performed - first, then the indent is applied." - -paramindents -default line -choices {none line position} -choicelabels { - line\ - " Use leading whitespace in - the line in which the - placeholder occurs." - position\ - " Use the position in - the line in which the - placeholder occurs." - none\ - " No indents applied to - subsequent placeholder value - lines. This will usually - result in text awkwardly - ragged unless the source code - has also been aligned with the - left margin or the value has - been manually padded." - } -help\ - "How indenting is done for subsequent lines in a - multi-line placeholder substitution value. - The 1st line or a single line value is always - placed at the placeholder. - paramindents are performed after the main - template has been indented/undented. - (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) - " - #choicelabels indented by 1 char is clearer for -return string - and reasonable in table - -return -default string -choices {dict list string args}\ - -choicelabels { - dict\ - " Return a dict with keys - 'template', 'params' and - 'errors'" - string\ - " Return a single result - being the string with - placeholders substituted." - list\ - " Return a 2 element list. - The first is itself a list - of plaintext portions of the - template, split at each point - at which placeholders were - present. The second element - of the outer list is a list - of placeholder values if -eval - is 1, or a list of the raw - placeholder strings if -eval - is 0." - args\ - " Return a list where the first - element is a list of template - plaintext sections as per the - 'list' return mechanism, but the - placeholder items are individual - items in the returned list. - This can be useful when passing - the expanded result of a tstr - command to another function - which expects the placeholders - as individual arguments" - } - -eval -default 1 -type boolean -help\ - "Whether to evaluate the \$\{\} placeholders. - When -return is string, -eval should generally be set to 1. - For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. - contained variables in that case should be braced or whitespace separated, or the variable - name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" - @values -min 0 -max 1 - templatestring -help\ - "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} - where $var will be substituted from the calling context - The placeholder itself can contain plaintext portions as well as variables. - It can contain commands in square brackets if -allowcommands is true - e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - - Escape sequences such as \\n and unicode escapes are processed within placeholders. - " - }] - - proc tstr {args} { - #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only - #set argd [punk::args::get_by_id ::punk::lib::tstr $args] - #set templatestring [dict get $argd values templatestring] - #set opt_allowcommands [dict get $argd opts -allowcommands] - #set opt_return [dict get $argd opts -return] - #set opt_eval [dict get $argd opts -eval] - - set templatestring [lindex $args end] - set arglist [lrange $args 0 end-1] - set opts [dict create\ - -allowcommands 0\ - -undent 1\ - -indent ""\ - -paramindents line\ - -eval 1\ - -return string\ - ] - if {"-allowcommands" in $arglist} { - set arglist [::punk::args::system::punklib_ldiff $arglist -allowcommands] - dict set opts -allowcommands 1 - } - if {[llength $arglist] % 2 != 0} { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" - } - } - dict for {k v} $arglist { - set fullk [tcl::prefix::match -error "" {-allowcommands -indent -undent -paramindents -return -eval} $k] - switch -- $fullk { - -indent - -undent - -paramindents - -return - -eval { - dict set opts $fullk $v - } - default { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args - return - } else { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" - } - } - } - } - set opt_allowcommands [dict get $opts -allowcommands] - set opt_paramindents [dict get $opts -paramindents] - set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] - if {$test_paramindents ni {none line position}} { - error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." - } - set opt_paramindents $test_paramindents - set opt_return [dict get $opts -return] - set opt_return [tcl::prefix::match -error "" {args dict list string} $opt_return] - if {$opt_return eq ""} { - } - set opt_eval [dict get $opts -eval] - - - set nocommands "-nocommands" - if {$opt_allowcommands == 1} { - set nocommands "" - } - - set opt_undent [dict get $opts -undent] - if {$opt_undent} { - set templatestring [punk::args::lib::undent $templatestring] - } - set opt_indent [dict get $opts -indent] - if {$opt_indent ne ""} { - set templatestring [punk::args::lib::indent $templatestring $opt_indent] - } - - #set parts [_tstr_split $templatestring] - if {[string first \$\{ $templatestring] < 0} { - set parts [list $templatestring] - } else { - set parts [_parse_tstr_parts $templatestring] - } - set textchunks [list] - #set expressions [list] - set params [list] - set idx 0 - set errors [dict create] - set lastline "" ;#todo - first line has placeholder? - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach {pt expression} $parts { - lappend textchunks $pt - incr idx ;#pt incr - - #ignore last expression - if {$idx == [llength $parts]} { - break - } - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - #lappend expressions $expression - #---------------------- - #REVIEW - JMN - #TODO - debug punk::args loading of @dynamic defs - #puts "-- $expression" - #---------------------- - #brk1 - literal newline not {\n} - set leader "" - if {[set brk1 [string first \n $expression]] >= 0} { - #undent left of paramstart only for lines of expression that arent on opening ${..} line - set tail [string range $expression $brk1+1 end] - set leader [string repeat " " [string length $lastline]] - set undentedtail [punk::args::lib::undentleader $tail $leader] - #set undentedtail [punk::lib::undent [string range $expression $brk1+1 end]] - set expression "[string range $expression 0 $brk1]$undentedtail" - } - if {$opt_eval} { - if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] - dict set errors [expr {[llength $params]-1}] $result - } else { - set result [string map [list \n "\n$leader"] $result] - lappend params $result - } - #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] - } else { - #JJJ - #REVIEW - #lappend params [subst -nocommands -novariables $expression] - lappend params $expression - } - append lastline [lindex $params end] ;#for current expression's position calc - - incr idx ;#expression incr - } - - if {$opt_return eq "dict"} { - return [dict create template $textchunks params $params errors $errors] - } - if {[dict size $errors]} { - set einfo "" - dict for {i e} $errors { - append einfo "parameter $i error: $e" \n - } - #REVIEW!!! - #TODO - fix - #puts stderr "tstr errors:\n$einfo\n" - } - - switch -- $opt_return { - list { - return [list $textchunks $params] - } - args { - #see example in tstr_test_one - return [list $textchunks {*}$params] - } - string { - #todo - flag to disable indent-matching behaviour for multiline param? - set out "" - set pt1 [lindex $parts 0] - set lastline_posn [string last \n $pt1] - if {$lastline_posn >= 0} { - set lastline [string range $pt1 $lastline_posn+1 end] - } else { - set lastline $pt1 - } - foreach pt $textchunks param $params { - if {$opt_paramindents eq "none"} { - append out $pt $param - } else { - set lastline_posn [string last \n $pt] - if {$lastline_posn >= 0} { - set lastline [string range $pt $lastline_posn+1 end] - } - if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent - } else { - #position - #TODO - detect if there are grapheme clusters - #This regsub doesn't properly space unicode double-wide chars or clusters - set lastindent "[regsub -all {\S} $lastline " "] " - } - if {$lastindent ne ""} { - set paramlines [split $param \n] - if {[llength $paramlines] == 1} { - append out $pt $param - } else { - append out $pt [lindex $paramlines 0] - foreach nextline [lrange $paramlines 1 end] { - append out \n $lastindent $nextline - } - } - } else { - append out $pt $param - } - append lastline $param - } - } - return $out - } - } - } - #test single placeholder tstr args where single placeholder must be an int - proc tstr_test_one {args} { - set argd [punk::args::parse $args withdef { - @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. - example: - set id 2 - tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] - } - - @values -min 2 -max 2 - template -type list -minsize 2 -maxsize 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - - but the tstr call in the example does this for you, and also passes in the id automatically" - - where -type int -help {Integer param for where clause. tstr mechanism above will pass the id as the second parameter} - }] - set template [dict get $argd values template] - set where [dict get $argd values where] - #set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] - set result [string cat [lindex $template 0] $where [lindex $template 1]] - return $result - } - proc _parse_tstr_parts {templatestring} { - if {$templatestring eq ""} { - return [list] - } - set chars [split $templatestring ""] - set in_placeholder 0 - set tchars "" - set echars "" - set parts [list] - set i 0 - foreach ch $chars { - if {!$in_placeholder} { - set nextch [lindex $chars [expr {$i+1}]] - if {"$ch$nextch" eq "\$\{"} { - set in_placeholder 2 ;#2 to signify we just entered placeholder - lappend parts $tchars - set tchars "" - } else { - append tchars $ch - } - } else { - if {$ch eq "\}"} { - if {[tcl::info::complete $echars]} { - set in_placeholder 0 - lappend parts $echars - set echars "" - } else { - append echars $ch - } - } else { - if {$in_placeholder == 2} { - #skip opening bracket dollar sign - set in_placeholder 1 - } else { - append echars $ch - } - } - } - incr i - } - if {$tchars ne ""} { - lappend parts $tchars - } - if {[llength $parts] % 2 == 0} { - #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list - lappend parts "" - } - return $parts - } - #based on punk::ansi::ta::_perlish_split - proc _tstr_split {text} { - if {$text eq ""} { - return {} - } - set list [list] - set start 0 - #ideally re should allow curlies within but we will probably need a custom parser to do it - #(js allows nested string interpolation) - #set re {\$\{[^\}]*\}} - set re {\$\{(?:(?!\$\{).)*\}} - - #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code - - #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW - while {[regexp -start $start -indices -- $re $text match]} { - lassign $match matchStart matchEnd - #puts "->start $start ->match $matchStart $matchEnd" - if {$matchEnd < $matchStart} { - puts "e:$matchEnd < s:$matchStart" - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] - incr start - if {$start >= [tcl::string::length $text]} { - break - } - continue - } - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] - set start [expr {$matchEnd+1}] - #? - if {$start >= [tcl::string::length $text]} { - break - } - } - return [lappend list [tcl::string::range $text $start end]] - } - - #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. - proc indent {text {prefix " "}} { - set result [list] - foreach line [split $text \n] { - if {[string trim $line] eq ""} { - lappend result "" - } else { - lappend result $prefix[string trimright $line] - } - } - return [join $result \n] - } - #dedent? - proc undent {text} { - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - regexp {^([\t ]*)} $lcp _m lcp - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - - #hacky - proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be - if {$text eq ""} { - return "" - } - set lines [split $text \n] - set nonblank [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - continue - } - lappend nonblank $ln - } - lappend nonblank "${leader}!!" - set lcp [longestCommonPrefix $nonblank] - if {$lcp eq ""} { - return $text - } - #regexp {^([\t ]*)} $lcp _m lcp - #lcp can be shorter than leader - set lcp [string range $lcp 0 [string length $leader]-1] - - if {$lcp eq ""} { - return $text - } - set len [string length $lcp] - set result [list] - foreach ln $lines { - if {[string trim $ln] eq ""} { - lappend result "" - } else { - lappend result [string range $ln $len end] - } - } - return [join $result \n] - } - #A version of textutil::string::longestCommonPrefixList - proc longestCommonPrefix {items} { - if {[llength $items] <= 1} { - return [lindex $items 0] - } - set items [lsort $items[unset items]] - set min [lindex $items 0] - set max [lindex $items end] - #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) - #(sort order nothing to do with length - e.g min may be longer than max) - if {[string length $min] > [string length $max]} { - set temp $min - set min $max - set max $temp - } - set n [string length $min] - set prefix "" - set i -1 - while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c - } - return $prefix - } - - #order-preserving - #(same as punk::lib) - proc lunique {list} { - set new {} - foreach item $list { - if {$item ni $new} { - lappend new $item - } - } - return $new - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::lib ---}] -} - -tcl::namespace::eval punk::args::argdocbase { - namespace export * - #use a? to test and create literal ansi here rather than relying on punk::ansi package presence - #e.g - #% a? bold - #- bold │SGR 1│sample│␛[1msample - #- ──────┼─────┼──────┼────────── - #- RESULT│ │sample│␛[1msample - proc B {} {return \x1b\[1m} ;#a+ bold - proc N {} {return \x1b\[22m} ;#a+ normal - proc I {} {return \x1b\[3m} ;#a+ italic - proc NI {} {return \x1b\[23m} ;#a+ noitalic - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::package { - variable PUNKARGS - lappend PUNKARGS [list { - @dynamic - @id -id "::punk::args::package::standard_about" - @cmd -name "%pkg%::about" -help\ - "About %pkg% - ... - " - -package_about_namespace -type string -optional 0 -help\ - "Namespace containing the package about procedures - Must contain " - -return\ - -type string\ - -default table\ - -choices {string table tableobject}\ - -choicelabels { - string\ - "A basic text layout" - table\ - "layout in table borders - (requires package: textblock)" - tableobject\ - "textblock::class::table object instance" - }\ - -help\ - "Choose the return type of the 'about' information" - topic -optional 1\ - -nocase 1\ - -default {*}\ - -choices {Description License Version Contact *}\ - -choicerestricted 0\ - -choicelabels { - - }\ - -multiple 1\ - -help\ - "Topic to display. Omit or specify as * to see all. - If * is included with explicit topics, * represents - the remaining unmentioned topics." - }] - proc standard_about {args} { - set argd [punk::args::parse $args withid ::punk::args::package::standard_about] - lassign [dict values $argd] leaders OPTS values received - - set pkgns [dict get $OPTS -package_about_namespace] - if {[info commands ${pkgns}::package_name] eq ""} { - error "punk::args::package::standard_about unable to find function ${pkgns}::package_name" - } - set pkgname [${pkgns}::package_name] - - set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] - if {![dict exists $received topic]} { - set topics $all_topics - } else { - # * represents all remaining topics not explicitly mentioned. - set val_topics [dict get $values topic] ;#if -multiple is true, this is a list - set explicit_topics [lsearch -all -inline -exact -not $val_topics "*"] - set topics [list] - foreach t $val_topics { - if {$t eq "*"} { - foreach a $all_topics { - if {$a ni $explicit_topics} { - lappend topics $a - } - } - } else { - lappend topics $t - } - } - } - if {$opt_return ne "string"} { - package require textblock ;#table support - set is_table 1 - set title [string cat {[} $pkgname {]} ] - set t [textblock::class::table new -title $title] - $t configure -frametype double -minwidth [expr {[string length $title]+2}] - - } else { - set topiclens [lmap t $topics {string length $t}] - set widest_topic [tcl::mathfunc::max {*}$topiclens] - set is_table 0 - set about "$pkgname\n" - append about [string repeat - $widest_topic] \n - } - foreach topic $topics { - if {[llength [info commands ::${pkgns}::get_topic_$topic]] == 1} { - set topic_contents [::${pkgns}::get_topic_$topic] - } else { - set topic_contents "" - } - if {!$is_table} { - set content_lines [split $topic_contents \n] - append about [format %-${widest_topic}s $topic] " " [lindex $content_lines 0] \n - foreach ln [lrange $content_lines 1 end] { - append about [format %-${widest_topic}s ""] " " $ln \n - } - } else { - $t add_row [list $topic $topic_contents] - } - } - - if {!$is_table} { - return $about - } else { - if {$opt_return eq "tableobject"} { - return $t - } - set result [$t print] - $t destroy - return $result - } - } - -} - -#usually we would directly call arg definitions near the defining proc, -# so that the proc could directly use the definition in its parsing. -# -#for punk::args we need to make sure the punk::args namespace is fully loaded before calling, so we do it at the end. -#arguably it may be more processor-cache-efficient to do together like this anyway. - -#can't do this here? - as there is circular dependency with punk::lib -#tcl::namespace::eval punk::args { -# foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist -# } -# set PUNKARGS "" -#} - -lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::punk::args::lib ::punk::args::package - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::args::system { - #*** !doctools - #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API - - #dict get value with default wrapper for tcl 8.6 - if {[info commands ::tcl::dict::getdef] eq ""} { - proc Dict_getdef {dictValue args} { - set keys [lrange $args 0 end-1] - if {[tcl::dict::exists $dictValue {*}$keys]} { - return [tcl::dict::get $dictValue {*}$keys] - } else { - return [lindex $args end] - } - } - } else { - #we pay a minor perf penalty for the wrap - interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef - } - - #name to reflect maintenance - home is punk::lib::ldiff - proc punklib_ldiff {fromlist removeitems} { - if {[llength $removeitems] == 0} {return $fromlist} - set result {} - foreach item $fromlist { - if {$item ni $removeitems} { - lappend result $item - } - } - return $result - } - -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::args [tcl::namespace::eval punk::args { - tcl::namespace::path {::punk::args::lib ::punk::args::system} - variable pkg punk::args - variable version - set version 0.2 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm deleted file mode 100644 index 6a4cc626..00000000 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm +++ /dev/null @@ -1,6558 +0,0 @@ -# -*- 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: punkshell/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 punk::args::tclcore 0.1.0 -# Meta platform tcl -# Meta license MIT -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args::tclcore 0 0.1.0] -#[copyright "2025"] -#[titledesc {punk::args definitions for tcl core commands}] [comment {-- Name section and table of contents description --}] -#[moddesc {tcl core argument definitions}] [comment {-- Description at end of page heading --}] -#[require punk::args::tclcore] -#[keywords module] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of punk::args::tclcore -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::args::tclcore -#[list_begin itemized] - -package require Tcl 8.6- -package require punk::args -package require punk::ansi -package require textblock -#*** !doctools -#[item] [package {Tcl 8.6}] -#[item] [package {punk::args}] -#[item] [package {textblock}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::args::tclcore { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase - #variable xyz - - #for tcllib - we can potentially parse the doctools to get this info. - #for tcl core commands - the data is stored in man pages - which are not so easy to parse. - #todo - link to man pages - - - #TODO - - #if we want colour in arg definitions -we need to respect nocolor or change colour to off/ on - #If color included in a definition - it will need to be reloaded when colour toggled(?) - #if {[catch {package require punk::ansi}]} { - # set has_punkansi 0 - # set A_WARN "" - # set A_RST "" - #} else { - # set has_punkansi 1 - # set A_WARN [a+ red] - # set A_RST "\x1b\[0m" - #} - - #we can't just strip ansi as there are non colour codes such as hyperlink that should be maintained whether color is on or off. - #for now we can use reverse - (like underline, is a non-colour attribute that remains effective when color off in punk::ansi) - set A_WARN \x1b\[7m - set A_RST \x1b\[0m - - variable manbase_tcl - variable manbase_ext - set patch [info patchlevel] - lassign [split $patch .] major - if {$major < 9} { - set manbase_tcl "https://tcl.tk/man/tcl/TclCmd" - set manbase_ext .htm - } else { - set manbase_tcl "https://tcl.tk/man/tcl9.0/TclCmd" - set manbase_ext .html - } - proc manpage_tcl {cmd} { - variable manbase_tcl - variable manbase_ext - return ${manbase_tcl}/${cmd}${manbase_ext} - } - - variable PUNKARGS - - namespace eval argdoc { - tcl::namespace::import ::punk::ansi::a+ - tcl::namespace::import ::punk::args::tclcore::manpage_tcl - # -- --- --- --- --- - #non colour SGR codes - # we can use these directly via ${$I} etc without marking a definition with @dynamic - #This is because they don't need to change when colour switched on and off. - set I [a+ italic] - set NI [a+ noitalic] - set B [a+ bold] - set N [a+ normal] - # -- --- --- --- --- - proc example {str} { - set str [string trimleft $str \n] - set block [punk::ansi::ansiwrap Web-gray [textblock::frame -ansibase [a+ Web-gray bold white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]] - set result [textblock::bookend_lines $block [a] "[a defaultbg] [a]"] - #puts $result - return $result - } - } - - - namespace eval argdoc { - variable PUNKARGS - - lappend PUNKARGS [list { - @id -id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition - @cmd -name ::punk::args::tclcore::argdoc::ensemble_subcommands_definition -help\ - "Helper function to return a punk::args definition snippet for subcommands" - @leaders -max 0 -min 0 - -groupdict -default {} -type dict -help\ - "Dictionary keyed on arbitrary groupname, where value - is a list of known subcommands that should be displayed - by groupname. Each groupname forms the title of a subtable - in the choices list. - Subcommands not assigned to a groupname will appear first - in an untitled subtable." - -columns -default 4 -type integer -help\ - "Max number of columns for all subtables in the choices - display area" - @values -min 1 -max 1 - ensemble -optional 0 -help\ - "Name of ensemble command" - - }] - proc ensemble_subcommands_definition {args} { - #args manually parsed - with use of argdef for unhappy-path only - if {![llength $args]} { - #punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args - punk::args::parse $args -errorstyle minimal withid ::punk::args::tclcore::argdoc::ensemble_subcommands_definition - return - } - set ensemble [lindex $args end] - set optlist [lrange $args 0 end-1] - if {[llength $optlist] % 2} { - #punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args - punk::args::parse $args -errorstyle minimal withid ::punk::args::tclcore::argdoc::ensemble_subcommands_definition - return - } - set defaults [dict create\ - -groupdict {}\ - -columns 4\ - ] - set optlist [dict merge $defaults $optlist] - dict for {k v} $optlist { - switch -- $k { - -groupdict - -columns {} - default { - #punk::args::get_by_id ::punk::args::tclcore::argdoc::ensemble_subcommands_definition $args - punk::args::parse $args -errorstyle minimal withid ::punk::args::tclcore::argdoc::ensemble_subcommands_definition - return - } - } - } - set opt_groupdict [dict get $optlist -groupdict] - set opt_columns [dict get $optlist -columns] - - package require punk::ns - set subdict [punk::ns::ensemble_subcommands -return dict $ensemble] - set allsubs [dict keys $subdict] - # ---------------------------------------------- - # manually defined group members may have subcommands that are obsoleted/missing - # we choose to make the situation obvious by re-classifying into a corresponding group with the " - MISSING" suffix - set checked_groupdict [dict create] - dict for {g members} $opt_groupdict { - set validmembers {} - set invalidmembers {} - foreach m $members { - if {$m in $allsubs} { - lappend validmembers $m - } else { - lappend invalidmembers $m - } - } - dict set checked_groupdict $g $validmembers - if {[llength $invalidmembers]} { - dict set checked_groupdict "${g}_MISSING" $invalidmembers - } - } - if {[dict exists $checked_groupdict ""]} { - set others [dict get $checked_groupdict ""] - dict unset checked_groupdict "" - } else { - set others [list] - } - - #REVIEW - set debug 0 - if {$debug} { - puts "punk::args::tclcore::argdoc::ensemble_subcommands_definition" - if {[catch { - ::punk::lib::pdict checked_groupdict - } msg]} { - puts stderr "punk::args::tclcore::ensemble_subcommands_definition Cannot call pdict\n$msg" - } - puts -------------------- - puts "$checked_groupdict" - puts -------------------- - } - - set opt_groupdict $checked_groupdict - # ---------------------------------------------- - set allgrouped [list] - dict for {g members} $opt_groupdict { - lappend allgrouped {*}$members - } - set choiceinfodict [dict create] - foreach {sc cmd} $subdict { - if {$sc ni $allgrouped} { - if {$sc ni $others} { - lappend others $sc - } - } - set cinfo [punk::ns::resolve_command {*}$cmd] - set tp [dict get $cinfo cmdtype] - - dict set choiceinfodict $sc [list [list resolved $cmd]] - - switch -- $tp { - ensemble - native { - dict lappend choiceinfodict $sc [list doctype $tp] - } - object { - dict lappend choiceinfodict $sc [list doctype oo] - } - } - - if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} { - dict lappend choiceinfodict $sc {doctype punkargs} - } - } - - set argdef "" - append argdef "subcommand -choicegroups \{" \n - append argdef " \"\" \{$others\}" \n - dict for {g members} $opt_groupdict { - append argdef " \"$g\" \{$members\}" \n - } - append argdef " \} -choicecolumns $opt_columns -choiceinfo {$choiceinfodict}" \n - - #todo -choicelabels - #detect subcommand further info available e.g if oo or ensemble or punk::args id exists.. - #consider a different mechanism to add a label on rhs of same line as choice (for (i) marker) - - return $argdef - } - } - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - # - # library commands loaded via auto_index - # - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - namespace eval argdoc { - lappend PUNKARGS [list { - @id -id ::parray - @cmd -name "Built-in: parray" -help\ - "Prints on standard output the names and values of all the elements in the - array arrayName, or just the names that match pattern (using the matching - rules of string_match) and their values if pattern is given. - ArrayName must be an array accessible to the caller of parray. It may either - be local or global. The result of this command is the empty string. - (loaded via auto_index)" - @values -min 1 -max 2 - arrayName -type string -help\ - "variable name of an array" - pattern -type string -optional 1 -help\ - "Match pattern possibly containing glob characters" - } "@doc -name Manpage: -url [manpage_tcl library]" ] - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::foreachLine - @cmd -name "Built-in: foreachLine" -help\ - "This reads in the text file named ${$I}filename${$NI} one line at a time (using system - defaults for reading text files). It writes that line to the variable named - by ${$I}varName${$NI} and then executes ${$I}body${$NI} for that line. The result value of ${$I}body${$NI} is - ignored, but error, return, break and continue may be used within it to - produce an error, return from the calling context, stop the loop, or go to - the next line respectively. The overall result of ${$B}foreachLine${$N} is the empty - string (assuming no errors from I/O or from evaluating the body of the loop); - the file will be closed prior to the procedure returning." - @values -min 3 -max 3 - varName - fileName - body - } "@doc -name Manpage: -url [manpage_tcl library]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::readFile - @cmd -name "Built-in: readFile" -help\ - "Reads in the file named in ${$I}filename${$NI} and returns its contents. The second - argument says how to read in the file, either as ${$B}text${$N} (using the system - defaults for reading text files) or as ${$B}binary${$N} (as uninterpreted bytes). - The default is ${$B}text${$N}. When read as text, this will include any trailing - newline. The file will be closed prior to the procedure returning." - @values -min 1 -max 2 - fileName - #todo punk::args::synopsis - show prefix highlighting - mode -type literalprefix(text)|literalprefix(binary) -optional 1 - #test - #mode -type {{literalprefix text | literalprefix binary}} - } "@doc -name Manpage: -url [manpage_tcl library]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::writeFile - @cmd -name "Built-in: writeFile" -help\ - "Writes the contents to the file named in ${$I}filename${$NI}. The optional second - argument says how to write to the file, either as ${$B}text${$N} (using the system - defaults for writing text files) or as ${$B}binary${$N} (as uninterpreted bytes). - The default is ${$B}text${$N}. If a trailing newline is required, it will need to - be provided in ${$I}contents${$NI}. The result of this command is the empty string; - the file will be closed prior to the procedure returning." - @values -min 2 -max 3 - fileName - mode -type literalprefix(text)|literalprefix(binary) -optional 1 - contents - } "@doc -name Manpage: -url [manpage_tcl library]" ] - - } - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - # (end of auto_index commands) - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - - - namespace eval argdoc { - punk::args::define { - @id -id ::tcl::info::args - @cmd -name "Built-in: tcl::info::args" -help\ - "Returns the names of the parameters to the procedure named ${$I}procname${$NI}." - @values -min 1 -max 1 - procname -type string -optional 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" - - punk::args::define { - @id -id ::tcl::info::body - @cmd -name "Built-in: tcl::info::body" -help\ - "Returns the body procedure named ${$I}procname${$NI}." - @values -min 1 -max 1 - procname -type string -optional 0 - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" - - punk::args::define { - @id -id ::tcl::info::default - @cmd -name "Built-in: tcl::info::default" -help\ - "If the parameter ${$I}parameter${$NI} for the procedure named ${$I}procname${$NI} - has a default value, stores that value in ${$I}varname${$NI} and returns ${$B}1${$N}. - Otherwise, returns ${$B}0${$N}." - @values -min 3 -max 3 - procname -type string -optional 0 - parameter - varname - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" - - punk::args::define { - @id -id ::tcl::info::cmdtype - @cmd -name "Built-in: tcl::info::cmdtype" -help\ - "Returns the type of the command named ${$I}commandName${$NI}. - Built-in types are: - ${$B}alias${$N} - ${$I}commandName${$NI} was created by 'interp alias'. In a safe interpreter an - alias is only visible if both the alias and the target are visible. - ${$B}coroutine${$N} - ${$I}commandName${$NI} was created by 'coroutine'. - ${$B}ensemble${$N} - ${$I}commandName${$NI} was created by 'namespace ensemble'. - ${$B}import${$N} - ${$I}commandName${$NI} was created by 'namespace import'. - ${$B}native${$N} - ${$I}commandName${$NI} was created by the 'Tcl_CreateObjCommand' interface - directly without further registration of the type of command. - ${$B}object${$N} - ${$I}commandName${$NI} is the public comand that represents an instance - of oo::object or one of its subclasses. - ${$B}privateObject${$N} - ${$I}commandName${$NI} is the private command, my by default, - that represents an instance of oo::object or one of its subclasses. - ${$B}proc${$N} - ${$I}commandName${$NI} was created by 'proc'. - ${$B}interp${$N} - ${$I}commandName${$NI} was created by 'interp create'. - ${$B}zlibStream${$N} - ${$I}commandName${$NI} was created by 'zlib stream'. - " - @values -min 1 -max 1 - commandName -type string - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl info]" - - punk::args::define { - @id -id ::oo::InfoObject::call - @cmd -name "Built-in: oo::InfoObject::call" -help\ - "Returns a description of the method implementations that are used to provide - ${$I}object's${$NI} implementation of ${$I}method${$NI}. This consists of a - list of lists of four elements, where each sublist consists of: - element 0: a word that describes the general type of method implementation, being - one of - ${$B}method${$N} for an ordinary method, ${$B}filter${$N} for an applied filter, - ${$B}private${$N} for a private method, and ${$B}unknown${$N} for a method that - is invoked as part of unknown method handling. - element 1: a word giving the name of the particular method invoked (which is always - the same as method for the ${$B}method${$N} type, and \"${$B}unknown${$N}\" - for the ${$B}unknown${$N} type) - element 2: a word giving what defined the method (the fully qualified name of the - class, or the literal string ${$B}object${$N} if the method implementation is on - an instance) - element 3: a word describing the type of method implementation - (see ${$B}info object methodtype${$N} - - Note that there is no inspection of whether the method implementations actually use - ${$B}next${$N} to transfer control along the call chain, and the call chains that - this command files do not actually contain private methods." - @values -min 2 -max 2 - object - method - } "@doc -name Manpage: -url [manpage_tcl info]" - - proc info_subcommands {} { - #package require punk::ns - #set subdict [punk::ns::ensemble_subcommands -return dict info] - #set allsubs [dict keys $subdict] - dict set groups "system" {hostname library nameofexecutable patchlevel script sharedlibextension tclversion} - dict set groups "proc introspection" {args body default} - dict set groups "variables" {constant consts exists globals locals vars} - dict set groups "oo object introspection" {class object} - - return [ensemble_subcommands_definition -groupdict $groups -columns 4 info] - } - set DYN_INFO_SUBCOMMANDS {${[punk::args::tclcore::argdoc::info_subcommands]}} - lappend PUNKARGS [list { - @dynamic - @id -id ::info - @cmd -name "Built-in: info" -help\ - "Information about the state of the Tcl interpreter" - @leaders -min 1 -max 1 - ${$DYN_INFO_SUBCOMMANDS} - @values -min 0 - - } "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl array]" ] - } - - - - #An idiom for sharing common features - incomplete - todo work out what happens with (default)::id that has leaders,opts,values - #todo @cmd -help+ text (append to existing help that came from a default?) - lappend PUNKARGS [list { - @id -id "(default)::tcl::binary::*::base64" - @cmd -help\ - "The base64 binary encoding is commonly used in mail messages and XML documents, - and uses mostly upper and lower case letters and digits. It has the distinction - of being able to be rewrapped arbitrarily without losing information. - " - } "@doc -name Manpage: -url [manpage_tcl binary]" ] - lappend PUNKARGS [list { - @id -id "::tcl::binary::encode::base64" - @default -id (default)::tcl::binary::*::base64 - @cmd -name "binary encode base64" - -maxlen -type integer -help\ - "Indicates that the output should be split into lines of no more than length - characters. By default, lines are not split." - -wrapchar -type character -default \n -help\ - "Indicates that, when lines are split because of the -maxlen option, character - should be used to separate lines. By default, this is a newline character, \"\\n\"." - @values -min 1 -max 1 - data -type string - } ] - lappend PUNKARGS [list { - @id -id "::tcl::binary::decode::base64" - @default -id (default)::tcl::binary::*::base64 - @cmd -name "binary decode base64" - -strict -type none -help\ - "Instructs the decoder to throw an error if it encounters any characters that - are not strictly part of the encoding itself. Otherwise it ignores them. - RFC 2045 calls for base64 decoders to be non-strict." - @values -min 1 -max 1 - data -type string - } ] - - - lappend PUNKARGS [list { - @id -id "(default)::tcl::binary::*::hex" - @cmd -help\ - "The hex binary encoding converts each byte to a pair of hexadecimal digits - that represent the byte value as a hexadecimal integer. When encoding, lower - characters are used. When decoding, upper and lower characters are accepted." - } "@doc -name Manpage: -url [manpage_tcl binary]" ] - lappend PUNKARGS [list { - @id -id "::tcl::binary::encode::hex" - @default -id (default)::tcl::binary::*::hex - @cmd -name "binary encode hex" - @values -min 1 -max 1 - data -type string - } ] - lappend PUNKARGS [list { - @id -id "::tcl::binary::decode::hex" - @default -id (default)::tcl::binary::*::hex - @cmd -name "binary encode hex" - -strict -type none -help\ - "Instructs the decoder to throw an error if it encounters whitespace - characters. Otherwise it ignores them." - @values -min 1 -max 1 - data -type string - }] - - - lappend PUNKARGS [list { - @id -id "(default)::tcl::binary::*::uuencode" - @cmd -help\ - "The uuencode binary encoding used to be common for transfer of data between Unix - systems and on USENT, but is less common these days, having been largely - superseded by the base64 binary encoding. - Note that neither the encoder nor the decoder handle the header and footer of the - uuencode format." - } "@doc -name Manpage: -url [manpage_tcl binary]" ] - lappend PUNKARGS [list { - @id -id "::tcl::binary::encode::uuencode" - @default -id (default)::tcl::binary::*::uuencode - #todo @cmd -help+ "Changing the options may produce files that other implementations of decoders cannot process" - @cmd -name "binary encode uuencode" - -maxlen -type integer -default 61 -range {5 85} -help\ - "Indicates the maximum number of characters to produce for each encoded line. - The valid range is 5 to 85. Line lengths outside that range cannot be - accommodated by the encoding format." - -wrapchar -type string -default \n -help\ - "Indicates the character(s) to use to mark the end of each encoded line. - Acceptable values are a sequence of zero or more character from the set - { \\x09 (TAB), \\x0B (VT), \\x0C (FF), \\x0D (CR) } followed by zero or - one newline \\x0A (LF). Any other values are rejected because they would - generate encoded text that could not be decoded. The default value is a - single newline. - " - @values -min 1 -max 1 - data -type string - } ] - lappend PUNKARGS [list { - @id -id "::tcl::binary::decode::uuencode" - @default -id (default)::tcl::binary::*::uuencode - @cmd -name "binary decode uuencode" - -strict -type none -help\ - "Instructs the decoder to throw an error if it encounters anything outside - of the standard encoding format. Without this option, the decoder tolerates - some deviations, mostly to forgive reflows of lines between the encoder and - decoder." - @values -min 1 -max 1 - data -type string - } ] - - namespace eval argdoc { - lappend PUNKARGS [list { - @id -id "::tcl::encoding::dirs" - @cmd -name "encoding dirs" -help\ - "Tcl can load encoding data files from the file system that describe - additional encodings for it to work with. This command sets the search - path for ${$B}*.enc${$N} encoding data files to the list of directories - ${$I}directoryList${$NI}. If ${$I}directoryList${$NI} is omitted then the - command returns the current list of directories that make up the search - path. It is an error for ${$I}directoryList${$NI} to not be a valid list. - If, when a search for an encoding data file is happening, an element in - ${$I}directoryList${$NI} does not refer to a readable, searchable - directory, that element is ignored." - @values -min 0 -max 1 - directoryList -optional 1 -type list - } "@doc -name Manpage: -url [manpage_tcl encoding]" ] - } - - lappend PUNKARGS [list { - @id -id ::time - @cmd -name "Built-in: time" -help\ - "Calls the Tcl interpreter count times to evaluate script - (or once if count is not specified). It will then return - a string of the form - 503.2 microseconds per iteration - which indicates the average amount of time required per - iteration, in microseconds. Time is measured in elapsed - time, not CPU time. - (see also: timerate)" - @values -min 1 -max 2 - script -type script - count -type integer -default 1 -optional 1 - } "@doc -name Manpage: -url [manpage_tcl time]" ] - - namespace eval argdoc { - lappend PUNKARGS [list { - @id -id ::tcl::chan::blocked - @cmd -name "Built-in: tcl::chan::blocked" -help\ - "This tests whether the last input operation on the channel called ${$I}channel${$NI} - failed because it would otherwise have caused the process to block, and returns 1 - if that was the case. It returns 0 otherwise. Note that this only ever returns 1 - when the channel has been configured to be non-blocking; all Tcl channels have - blocking turned on by default" - @values -min 1 -max 1 - channel -help \ - "" - } "@doc -name Manpage: -url [manpage_tcl chan]" ] - - lappend PUNKARGS [list { - @id -id ::tcl::chan::close - @cmd -name "Built-in: tcl::chan::close" -help\ - "Close and destroy the channel called channel. Note that this deletes all existing file-events - registered on the channel. If the direction argument (which must be read or write or any - unique abbreviation of them) is present, the channel will only be half-closed, so that it can - go from being read-write to write-only or read-only respectively. If a read-only channel is - closed for reading, it is the same as if the channel is fully closed, and respectively similar - for write-only channels. Without the direction argument, the channel is closed for both reading - and writing (but only if those directions are currently open). It is an error to close a - read-only channel for writing, or a write-only channel for reading. - As part of closing the channel, all buffered output is flushed to the channel's output device - (only if the channel is ceasing to be writable), any buffered input is discarded (only if the - channel is ceasing to be readable), the underlying operating system resource is closed and - channel becomes unavailable for future use (both only if the channel is being completely closed). - - If the channel is blocking and the channel is ceasing to be writable, the command does not return - until all output is flushed. If the channel is non-blocking and there is unflushed output, the - channel remains open and the command returns immediately; output will be flushed in the - background and the channel will be closed when all the flushing is complete. - - If channel is a blocking channel for a command pipeline then chan close waits for the child - processes to complete. - - If the channel is shared between interpreters, then chan close makes channel unavailable in the - invoking interpreter but has no other effect until all of the sharing interpreters have closed the - channel. When the last interpreter in which the channel is registered invokes chan close (or close), - the cleanup actions described above occur. With half-closing, the half-close of the channel only - applies to the current interpreter's view of the channel until all channels have closed it in that - direction (or completely). See the interp command for a description of channel sharing. - - Channels are automatically fully closed when an interpreter is destroyed and when the process exits. - Channels are switched to blocking mode, to ensure that all output is correctly flushed before the - process exits. - - The command returns an empty string, and may generate an error if an error occurs while flushing - output. If a command in a command pipeline created with open returns an error, chan close generates - an error (similar to the exec command.) - - Note that half-closes of sockets and command pipelines can have important side effects because they - result in a shutdown() or close() of the underlying system resource, which can change how other - processes or systems respond to the Tcl program. - - Channels are automatically closed when an interpreter is destroyed and when the process exits. - From 8.6 on (TIP#398), nonblocking channels are no longer switched to blocking mode when exiting; - this guarantees a timely exit even when the peer or a communication channel is stalled. To ensure - proper flushing of stalled nonblocking channels on exit, one must now either (a) actively switch - them back to blocking or (b) use the environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT, which when - set and not equal to “0” restores the previous behavior." - @values -min 1 -max 1 - channel - direction -optional 1 -choices {read write} - } "@doc -name Manpage: -url [manpage_tcl chan]" ] - - lappend PUNKARGS [list { - @id -id ::fconfigure - @cmd -name "Built-in: chan configure" -help\ - "Query or set the configuration options of the channel named ${$I}channel${$NI} - If no ${$I}optionName${$NI} or ${$I}value${$NI} arguments are supplied, the - command returns a list containing alternating option names and values for the - channel. If ${$I}optionName${$NI} is supplied but no ${$I}value${$NI} then the - command returns the current value of the given option. If one or more pairs - of ${$I}optionName${$NI} and ${$I}value${$NI} are supplied, the command sets each - of the named options to the corresponding value; in this case the return - value is an empty string. - - The options described below are supported for all channels. In addition, each - channel type may add options that only it supports. See the manual entry for - the command that creates each type of channel for the options supported by - that specific type of channel. For example, see the manual entry for the - ${$B}socket${$N} command for additional options for sockets, and the ${$B}open${$N} - command for additional options for serial devices. - ${$B}-blocking${$N} ${$I}boolean${$NI} - The ${$B}-blocking${$N} option determines whether I/O operations on the - channel can cause the process to block indefinitely. The value of the - option must be a proper boolean value. Channels are normally in blocking - mode; if a channel is placed into non-blocking mode it will affect the - operation of the ${$B}chan gets, chan read, chan puts, chan flush,${$N} - and ${$B}chan close${$N} commands; see the documentation for those - commands for details. For non-blocking mode to work correctly, the - application must be using the Tcl event loop (e.g. by calling - ${$B}Tcl_DoOneEvent${$N} or invoking the ${$B}vwait${$N} command). - ${$B}-buffering${$N} ${$I}newValue${$NI} - If ${$I}newValue${$NI} is ${$B}full${$N} then the I/O system will buffer output until its - internal buffer is full or until the ${$B}chan flush${$N} command is invoked. If - ${$I}newValue${$NI} is ${$B}line${$N}, then the I/O system will automatically flush output for - the channel whenever a newline character is output. If ${$I}newValue${$NI} is ${$B}none${$N}, - the I/O system will flush automatically after every output operation. The - default is for ${$B}-buffering${$N} to be set to ${$B}full${$N} except for channels that - connect to terminal-like devices; for these channels the initial setting - is ${$B}line${$N}. Additionally, ${$B}stdin${$N} and ${$B}stdout${$N} are initially set to ${$B}line${$N}, and - ${$B}stderr${$N} is set to ${$B}none${$N}. - ${$B}-buffersize${$N} ${$I}newSize${$NI} - ${$I}newSize${$NI} must be an integer; its value is used to set the size of buffers, - in bytes, subsequently allocated for this channel to store input or output. - ${$I}newSize${$NI} must be a number of no more than one million, allowing buffers of - up to one million bytes in size. - ${$B}-encoding${$N} ${$I}name${$NI} - - ${$B}-eofchar${$N} ${$I}char${$NI} - - ${$B}-profile${$N} ${$I}profile${$NI} - - ${$B}-translation${$N} ${$I}translation${$NI}" - - @form -form {getall} - @values -min 1 -max 1 - channel - @form -form {getone} - @values -min 2 -max 2 - channel - optionName - - @form -form {set} - @values -min 3 -max -1 - channel - "optionName value" -type {string any} -typesynopsis {${$I}optionName value${$NI}} -multiple 1 -optional 0 - - } "@doc -name Manpage: -url [manpage_tcl chan]" ] - - - - lappend PUNKARGS [list { - @id -id ::tcl::chan::eof - @cmd -name "Built-in: tcl::chan::eof"\ - -summary\ - "Check for end of file condition on channel"\ - -help\ - "Test whether the last input operation on the channel called ${$I}channel${$NI} - failed because the end of the data stream was reached, returning 1 if end-of-file - was reached, and 0 otherwise." - @values -min 1 -max 1 - channel -help \ - "" - } "@doc -name Manpage: -url [manpage_tcl chan]" ] - - #event - lappend PUNKARGS [list { - @id -id ::tcl::chan::flush - @cmd -name "Built-in: tcl::chan::flush"\ - -summary\ - "Flush pending output."\ - -help\ - "Ensures that all pending output for the channel called channel is written. - If the channel is in blocking mode the command does not return until all the buffered output - has been flushed to the channel. If the channel is in non-blocking mode, the command may - return before all buffered output has been flushed; the remainder will be flushed in the - background as fast as the underlying file or device is able to absorb it." - @values -min 1 -max 1 - channel - } "@doc -name Manpage: -url [manpage_tcl chan]" ] - - lappend PUNKARGS [list { - @id -id ::tcl::chan::gets - @cmd -name "Built-in: tcl::chan::gets"\ - -summary\ - "Read a line from channel."\ - -help\ - "Reads a line from the channel consisting of all characters up to the next end-of-line sequence - or until end of file is seen. The line feed character corresponding to end-of-line sequence is - not included as part of the line. If the varName argument is specified, the line is stored in - the variable of that name and the command returns the length of the line. If varName is not - specified, the command returns the line itself as the result of the command. - If a complete line is not available and the channel is not at EOF, the command will block in the - case of a blocking channel. For non-blocking channels, the command will return the empty string - as the result in the case of varName not specified and -1 if it is. - - If a blocking channel is already at EOF, the command returns an empty string if varName is not - specified. Note an empty string result can also be returned when a blank line (no characters - before the next end of line sequence). The two cases can be distinguished by calling the chan eof - command to check for end of file. If varName is specified, the command returns -1 on end of file. - There is no ambiguity in this case because blank lines result in 0 being returned. - - If a non-blocking channel is already at EOF, the command returns an empty line if varName is not - specified. This can be distinguished from an empty line being returned by either a blank line - being read or a full line not being available through the use of the chan eof and chan blocked - commands. If chan eof returns true, the channel is at EOF. If chan blocked returns true, a full - line was not available. If both commands return false, an empty line was read. If varName was - specified for a non-bocking channel at EOF, the command returns -1. This can be distinguished - from full line not being available either by chan eof or chan blocked as above. Note that when - varName is specified, there is no need to distinguish between eof and blank lines as the latter - will result in the command returning 0. - - If the encoding profile strict is in effect for the channel, the command will raise an exception - with the POSIX error code EILSEQ if any encoding errors are encountered in the channel input data. - The file pointer remains unchanged and it is possible to introspect, and in some cases recover, by - changing the encoding in use" - @values -min 1 -max 2 - channel - varName -optional 1 - } "@doc -name Manpage: -url [manpage_tcl chan]" ] - #isbinary - #names - #pending - lappend PUNKARGS [list { - @id -id ::tcl::chan::pipe - @cmd -name "Built-in: tcl::chan::pipe"\ - -summary\ - "Create a standalone pipe."\ - -help\ - "Creates a standalone pipe whose read- and write-side channels are returned - as a 2-element list, the first element being the read side and the second - write side. Can be useful e.g. to redirect separately ${$B}stderr${$N} and ${$B}stdout${$N} - from a subprocess. To do this spawn with \"2>@\" or \">@\" redirection - operators onto the write side of a pipe, and then immediately close it - in the parent. This is necessary to get an EOF on the read side once the - child has exited or otherwise closed its output. - Note that the pipe buffering semantics can vary at the operating system - level substantially; it is not safe to assume that a write performed on - the output side of the pipe will appear instantly to the input side. - This is a fundamental difference and Tcl cannot conceal it. The overall - stream semantics ${$I}are${$NI} compatible, so blocking reads and writes - will not see most of the differences, but the details of what exactly gets - written when are not. This is most likely to show up when using pipelines - for testing; care should be taken to ensure that deadlocks do not occur - and that potential short reads are allowed for." - @values -min 0 -max 0 - } "@doc -name Manpage: -url [manpage_tcl chan]" ] - - lappend PUNKARGS [list { - @id -id ::tcl::chan::pop - @cmd -name "Built-in: tcl::chan::pop"\ - -summary\ - "Remove topmost channel transform."\ - -help\ - "Removes the topmost transformation from the channel ${$I}channel${$NI}, if there is any. - If there are no transformations added to channel, this is equivalent to - ${$B}chan${$N} close of that channel. The result is normally the empty string, but can - be an error in some situations (i.e. where the underlying system stream is - closed and that results in an error)." - @values -min 1 -max 1 - channel -type string - } "@doc -name Manpage: -url [manpage_tcl chan]" ] - - lappend PUNKARGS [list { - @id -id ::tcl::chan::puts - @cmd -name "Built-in: tcl::chan::puts"\ - -summary\ - "Write to a channel."\ - -help\ - "Writes ${$I}string${$NI} to the channel named ${$I}channel${$NI} followed by a newline character. A - trailing newline character is written unless the optional flag ${$B}-nonewline${$N} is - given. If channel is omitted, the string is written to the standard output - channel, ${$B}stdout${$N}. - Newline characters in the output are translated by ${$B}chan puts${$N} to platform-specific - end-of-line sequences according to the currently configured value of the - ${$B}-translation${$N} option for the channel (for example, on PCs newlines are normally - replaced with carriage-return-linefeed sequences; see ${$B}chan configure${$N} for details). - - Tcl buffers output internally, so characters written with ${$B}chan puts${$N} may not appear - immediately on the output file or device; Tcl will normally delay output until the - buffer is full or the channel is closed. You can force output to appear - immediately with the ${$B}chan flush${$N} command. - - When the output buffer fills up, the ${$B}chan puts${$N} command will normally block until - all the buffered data has been accepted for output by the operating system. If - channel is in non-blocking mode then the ${$B}chan puts${$N} command will not block even if - the operating system cannot accept the data. Instead, Tcl continues to buffer the - data and writes it in the background as fast as the underlying file or device can - accept it. The application must use the Tcl event loop for non-blocking output to - work; otherwise Tcl never finds out that the file or device is ready for more - output data. It is possible for an arbitrarily large amount of data to be buffered - for a channel in non-blocking mode, which could consume a large amount of memory. - To avoid wasting memory, non-blocking I/O should normally be used in an - event-driven fashion with the ${$B}chan event${$N} command (do not invoke ${$B}chan puts${$N} unless - you have recently been notified via a file event that the channel is ready for more - output data). - - The command will raise an error exception with POSIX error code ${$B}EILSEQ${$N} if the - encoding profile ${$B}strict${$N} is in effect for the channel and the output data cannot be - encoded in the encoding configured for the channel. Data may be partially written - to the channel in this case." - @opts -prefix 0 - -nonewline -type none - @values -min 1 -max 2 - channel -type string -optional 1 - string -type string - } "@doc -name Manpage: -url [manpage_tcl chan]" ] - - } - - lappend PUNKARGS [list { - @id -id ::tcl::chan::read - @cmd -name "Built-in: tcl::chan::read"\ - -summary\ - "Read from a channel."\ - -help\ - "In the first form, the result will be the next numChars characters read from the channel named - channel; if numChars is omitted, all characters up to the point when the channel would signal a - failure (whether an end-of-file, blocked or other error condition) are read. In the second form - (i.e. when numChars has been omitted) the flag -nonewline may be given to indicate that any - trailing newline in the string that has been read should be trimmed. - If channel is in non-blocking mode, chan read may not read as many characters as requested: once - all available input has been read, the command will return the data that is available rather - than blocking for more input. If the channel is configured to use a multi-byte encoding, then - there may actually be some bytes remaining in the internal buffers that do not form a complete - character. These bytes will not be returned until a complete character is available or end-of-file - is reached. The -nonewline switch is ignored if the command returns before reaching the end of the - file. - - Chan read translates end-of-line sequences in the input into newline characters according to the - -translation option for the channel (see chan configure above for a discussion on the ways in - which chan configure will alter input). - - When reading from a serial port, most applications should configure the serial port channel to be - non-blocking, like this: - - chan configure channel -blocking 0 - - Then chan read behaves much like described above. Note that most serial ports are comparatively - slow; it is entirely possible to get a readable event for each character read from them. Care - must be taken when using chan read on blocking serial ports: - - chan read channel numChars - In this form chan read blocks until numChars have been received from the serial port. - chan read channel - In this form chan read blocks until the reception of the end-of-file character, see - chan configure -eofchar. If there no end-of-file character has been configured for the - channel, then chan read will block forever. - - If the encoding profile strict is in effect for the channel, the command will raise an exception - with the POSIX error code EILSEQ if any encoding errors are encountered in the channel input data. - If the channel is in blocking mode, the error is thrown after advancing the file pointer to the - beginning of the invalid data. The successfully decoded leading portion of the data prior to the - error location is returned as the value of the -data key of the error option dictionary. If the - channel is in non-blocking mode, the successfully decoded portion of data is returned by the - command without an error exception being raised. A subsequent read will start at the invalid data - and immediately raise a EILSEQ POSIX error exception. Unlike the blocking channel case, the -data - key is not present in the error option dictionary. In the case of exception thrown due to encoding - errors, it is possible to introspect, and in some cases recover, by changing the encoding in use. - See ENCODING ERROR EXAMPLES later." - - @form -form readchars - @values -min 1 -max 2 - channel - numChars -type integer -optional 1 - - @form -form read - @opts - -nonewline -type none - @values -min 1 -max 1 - channel - - } "@doc -name Manpage: -url [manpage_tcl chan]" ] - - lappend PUNKARGS [list { - @id -id ::tcl::chan::seek - @cmd -name "Built-in: tcl::chan::seek"\ - -summary\ - "Set channel access position as byte offset."\ - -help\ - "Sets the current access position within the underlying data stream for the channel named - channel to be offset bytes relative to origin. - Offset must be an integer (which may be negative) - The origin argument defaults to start. - - Chan seek flushes all buffered output for the channel before the command returns, even if the - channel is in non-blocking mode. It also discards any buffered and unread input. This command - returns an empty string. An error occurs if this command is applied to channels whose - underlying file or device does not support seeking. - - Note that offset values are byte offsets, not character offsets. Both chan seek and chan tell - operate in terms of bytes, not characters, unlike chan read." - @values -min 2 -max 3 - channel - offset -type integer - origin -type string\ - -default start\ - -optional 1\ - -choicecolumns 1\ - -choices {start current end}\ - -choicelabels { - start\ - " The new access position will be offset bytes from the start of the underlying file or device." - current\ - " The new access position will be offset bytes from the current access position; a negative - offset moves the access position backwards in the underlying file or device." - enc\ - " The new access position will be offset bytes from the end of the file or device. A negative - offset places the access position before the end of file, and a positive offset places the - access position after the end of file." - } - } "@doc -name Manpage: -url [manpage_tcl chan]" ] - - lappend PUNKARGS [list { - @id -id ::tcl::chan::tell - @cmd -name "Built-in: tcl::chan::tell"\ - -summary\ - "Report channel access position as byte offset."\ - -help\ - "Returns a number giving the current access position within the underlying - data stream for the channel named channel. This value returned is a byte - offset that can be passed to ${[a+ bold]}chan seek${[a+ normal]} in order - to set the channel to a particular position. Note that this value is in - terms of bytes, not characters like ${[a+ bold]}chan read${[a+ normal]}. The - value returned is -1 for channels that do not support seeking." - @values -min 1 -max 1 - channel -help \ - "" - } "@doc -name Manpage: -url [manpage_tcl chan]" ] - - - lappend PUNKARGS [list { - @id -id ::tcl::chan::truncate - @cmd -name "Built-in: tcl::chan::truncate"\ - -summary\ - "Truncate channel to specified length or current byte offset."\ - -help\ - "Sets the byte length of the underlying data stream for the channel to be - length (or to the current byte offset within the underlying data stream if - length is omitted). The channel is flushed before truncation." - #todo - auto synopsis? - #@form -synopsis\ - # "chan truncate channel ?length?" - @values -min 1 -max 2 - channel -help \ - "" - length -optional 1 -type integer - } "@doc -name Manpage: -url [manpage_tcl chan]" ] - - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - #dict - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - namespace eval argdoc { - lappend PUNKARGS [list { - @id -id ::tcl::dict::append - @cmd -name "Built-in: tcl::dict::append" -help\ - "This appends the given string (or strings) to the value that the given - key maps to in the dictionary value contained in the given variable, - writing the resulting dictionary value back to that variable. Non-existant - keys are treated as if they map to an empty string. The updated dictionary - value is returned." - @values -min 2 -max -1 - dictionaryVariable -type string -help \ - "" - key - string -type string -optional 1 -multiple 1 - } "@doc -name Manpage: -url [manpage_tcl dict]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::tcl::dict::create - @cmd -name "Built-in: tcl::dict::create" -help\ - "Return a new dictionary that contains each of the key/value mappings listed - as arguments (keys and values alternating, with each key being followed by - its associated value)" - @values -min 2 -max -1 - "key value" -type {string string} -typesynopsis {${$I}key${$NI} ${$I}value${$NI}} -optional 1 -multiple 1 - } "@doc -name Manpage: -url [manpage_tcl dict]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::tcl::dict::exists - @cmd -name "Built-in: tcl::dict::exists" -help\ - "This returns a boolean value indicating whether the given key (or path of - keys through a set of nested dictionaries) exists in the given dictionary - value. This returns a true value exactly when ${$B}dict get${$N} on that path will - succeed." - @values -min 2 -max -1 - dictionaryValue -type dict - key -type string -multiple 1 -optional 0 - } "@doc -name Manpage: -url [manpage_tcl dict]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::tcl::dict::for - @cmd -name "Built-in: tcl::dict::for" -help\ - "This command takes three arguments, the first a two-element list of - variable names (for the key and value respectively of each mapping in - the dictionary), the second the dictionary value to iterate across, and - the third a script to be evaluated for each mapping with the key and - value variable set appropriately (in the manner of ${$B}foreach${$N}). - The result of the command is an empty string. If any evlauation of the - body generates a ${$B}TCL_BREAK${$N} result, no further pairs from the - dictionary will be iterated over and the ${$B}dict for${$N} command will - terminate successfully immediately. If any evaluation of the body generates - a ${$B}TCL_CONTINUE${$N} result, this shall be treated exactly like a - normal ${$B}TCL_OK${$N} result. The order of iteration is the order in which - the keys were inserted into the dictionary." - @values -min 3 -max 3 - "{keyVariable valueVariable}" -type list -minsize 2 -maxsize 2 - dictionaryValue -type dict - body -type string -help\ - "Tcl script" - } "@doc -name Manpage: -url [manpage_tcl dict]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::tcl::dict::get - @cmd -name "Built-in: tcl::dict::get" -help\ - "Given a dictionary value (first argument) and a key (second argument), this - will retrieve the value for that key. Where several keys are supplied, the - behaviour of the command shall be as if the result of ${$B}dict get $dictVal $key${$N} - was passed as the first argument to ${$B}dict get${$N} with the remaining - arguments as second (and possibly subsequent) arguments. This facilitates - lookups in nested dictionaries. For example, the following two commands are - equivalent: - ${[punk::args::tclcore::argdoc::example { - dict get $dict foo bar spong - dict get [dict get [dict get $dict foo] bar] spong\ - } - ]} - If no keys are provided, ${$B}dict get${$N} will return a list containing pairs - of elements in a manner similar to ${$B}array get${$N}. That is, the first - element of each pair would be the key and the second element would be the value - for that key. - It is an error to attempt to retrieve a value for a key that is not present in - the dictionary. - " - @values -min 1 -max -1 - dictionaryValue -type dict - key -type string -multiple 1 -optional 1 - } "@doc -name Manpage: -url [manpage_tcl dict]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - punk::args::define { - @id -id ::tcl::dict::getdef - @cmd -name "Built-in: tcl::dict::getdef" -help\ - "This behaves the same as ${$B}dict get${$N} (with at least one ${$I}key${$NI} argument), - returning the value that the key path maps to in the dictionary - ${$I}dictionaryValue${$NI}, except that instead of producing an error because the - ${$I}key${$NI} (or one of the ${$I}key${$NI}s on the key path) is absent, it returns the - ${$I}default${$NI} argument instead. - Note that there must always be at least one ${$I}key${$NI} provided, and that ${$B}dict getdef${$N} and - ${$B}dict getwithdefault${$N} are aliases for each other." - @values -min 1 -max -1 - dictionaryValue -type dict - key -type string -multiple 1 -optional 0 - default -type any -optional 0 - } "@doc -name Manpage: -url [manpage_tcl dict]" - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - #use getdef to define getwithdefault - punk::args::define [punk::args::resolved_def -override {@id { - -id ::tcl::dict::getwithdefault - } @cmd { - -name "Built-in: tcl::dict::getwithdefault" - }} ::tcl::dict::getdef] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::tcl::dict::incr - @cmd -name "Built-in: tcl::dict::incr" -help\ - "This adds the given ${$I}increment${$NI} value (an integer that defaults to 1 if - not specified) to the value that the given key maps to in the dictionary - value contained in the given variable, writing the resulting dictionary - value back to that variable. Non-existent keys are treated as if they - map to 0. It is an error to increment a value for an existing key if that - value is not an integer. The updated dictionary value is returned. If - ${$I}dictionaryVariable${$NI} indicates an element that does not exist of an array - that has a default value set, the default value and will be used as the - value of the dictionary prior to the incrementing operation." - @values -min 2 -max 3 - dictionaryVariable -type string - key -type any - increment -type integer -default 1 -optional 1 - } "@doc -name Manpage: -url [manpage_tcl dict]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::tcl::dict::info - @cmd -name "Built-in: tcl::dict::info" -help\ - "This returns information (intended for display to people) about the - given dictionary though the format of this data is dependent on the - implementation of the dictionary. For dictionaries that are implemented - by hash tables, it is expected that this will return the string produced - by ${$B}Tcl_HashStats${$N}, similar to ${$B}array statistics${$N}." - @values -min 1 -max 1 - dictionaryValue -type dict - } "@doc -name Manpage: -url [manpage_tcl dict]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::tcl::dict::keys - @cmd -name "Built-in: tcl::dict::keys" -help\ - "Return a list of all keys in the given dictionary value. If a pattern is - supplied, only those keys that match it (according to the rules of ${$B}string - match${$N}) will be returned. The returned keys will be in the order that they - were inserted into the dictionary." - @values -min 1 -max 2 - dictionaryValue -type dict - globPattern -type string -optional 1 - } "@doc -name Manpage: -url [manpage_tcl dict]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::tcl::dict::lappend - @cmd -name "Built-in: tcl::dict::lappend" -help\ - "This appends the given items to the list value that the given key maps - to in the dictionary value contained in the given variable, writing the - resulting dictionary value back to that variable. Non-existent keys are - treated as if they map to an empty list, and it is legal for there to be - no items to append to the list. It is an error for the value that the key - maps to to not be representable as a list. The updated dictionary value - is returned. If ${$I}dictionaryVariable${$NI} indicates an element that does not - exist of an array that has a default value set, the default value and - will be used as the value of the dictionary prior to the list-appending - operation." - @values -min 2 -max -1 - dictionaryVariable -type dict - key -type any - value -type any -multiple 1 -optional 1 - } "@doc -name Manpage: -url [manpage_tcl dict]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::tcl::dict::map - @cmd -name "Built-in: tcl::dict::map" -help\ - "This command applies a transformation to each element of a dictionary, - returning a new dictionary. It takes three arguments: the first is a - two-element list of variable names (for the key and value respectively of - each mapping in the dictionary), the second the dictionary value to - iterate across, and the third a script to be evaluated for each mapping - with the key and value variables set appropriately (in the manner of ${$B}lmap${$N}). - In an iteration where the evaluated script completes normally (${$B}TCL_OK${$N}, as - opposed to an ${$B}error${$N}, etc.) the result of the script is put into an - accumulator dictionary using the key that is the current contents of the - keyVariable variable at that point. The result of the ${$B}dict map${$N} command is - the accumulator dictionary after all keys have been iterated over. - - If the evaluation of the body for any particular step generates a break, - no further pairs from the dictionary will be iterated over and the ${$B}dict - map${$N} command will terminate successfully immediately. If the evaluation of - the body for a particular step generates a continue result, the current - iteration is aborted and the accumulator dictionary is not modified. The - order of iteration is the natural order of the dictionary (typically the - order in which the keys were added to the dictionary; the order is the - same as that used in ${$B}dict for${$N})." - @values -min 3 -max 3 - "{keyVariable valueVariable}" -type list -minsize 2 -maxsize 2 - dictionaryValue -type dict - body -type script - } "@doc -name Manpage: -url [manpage_tcl dict]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::tcl::dict::merge - @cmd -name "Built-in: tcl::dict::merge" -help\ - "Return a dictionary that contains the contents of each of the - ${$I}dictionaryValue${$NI} arguments. Where two (or more) dictionaries - contain a mapping for the same key, the resulting dictionary maps that - key to the value according to the last dictionary on the command line - containing a mapping for that key." - @values -min 0 -max -1 - dictionaryValue -type dict -optional 1 -multiple 1 - } "@doc -name Manpage: -url [manpage_tcl dict]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::tcl::dict::remove - @cmd -name "Built-in: tcl::dict::remove" -help\ - "Return a new dictionary that is a copy of an old one passed in as first - argument except without mappings for each of the keys listed. It is legal - for there to be no keys to remove, and it also legal for any of the keys - to be removed to not be present in the input dictionary in the first place." - @values -min 1 -max -1 - dictionaryValue -type dict - key -type any -optional 1 -multiple 1 - } "@doc -name Manpage: -url [manpage_tcl dict]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::tcl::dict::replace - @cmd -name "Built-in: tcl::dict::replace" -help\ - "Return a new dictionary that is a copy of an old one passed in as first - argument except with some values different or some extra key/value pairs - added. It is legal for this command to be called with no key/value pairs, - but illegal for this command to be called with a key but no value." - @values -min 1 -max -1 - dictionaryValue -type dict - "key value" -type {any any} -optional 1 -multiple 1 - } "@doc -name Manpage: -url [manpage_tcl dict]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::tcl::dict::set - @cmd -name "Built-in: tcl::dict::set" -help\ - "This operation takes the name of a variable containing a dictionary value - and places an updated dictionary value in that variable containing a - mapping from the given key to the given value. When multiple keys are - present, this operation creates or updates a chain of nested dictionaries. - The updated dictionary value is returned. If ${$I}dictionaryVariable${$NI} indicates - an element that does not exist of an array that has a default value set, - the default value and will be used as the value of the dictionary prior to - the value insert/update operation." - @values -min 3 -max -1 - dictionaryVariable -type string - key -type string -optional 0 -multiple 1 - value -type any - } "@doc -name Manpage: -url [manpage_tcl dict]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::tcl::dict::size - @cmd -name "Built-in: tcl::dict::size" -help\ - "Return the number of key/value mappings in the given dictionary value." - @values -min 1 -max 1 - dictionaryValue -type dict - } "@doc -name Manpage: -url [manpage_tcl dict]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::tcl::dict::unset - @cmd -name "Built-in: tcl::dict::unset" -help\ - "This operation (the companion to ${$B}dict set${$NI}) takes the name of a variable - containing a dictionary value and places an updated dictionary value in - that variable that does not contain a mapping for the given key. Where - multiple keys are present, this describes a path through nested - dictionaries to the mapping to remove. At least one key must be specified, - but the last key on the key-path need not exist. All other components on - the path must exist. The updated dictionary value is returned. If - ${$I}dictionaryVariable${$NI} indicates an element that does not exist of an array - that has a default value set, the default value and will be used as the - value of the dictionary prior to the value remove operation." - @values -min 2 -max -1 - dictionaryVariable -type string - key -type string -optional 0 -multiple 1 - } "@doc -name Manpage: -url [manpage_tcl dict]" ] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - lappend PUNKARGS [list { - @id -id ::tcl::dict::update - @cmd -name "Built-in: tcl::dict::update" -help\ - "Execute the Tcl script in ${$I}body${$NI} with the value for each ${$I}key${$NI} (as found by - reading the dictionary value in ${$I}dictionaryVariable${$NI}) mapped to the variable - ${$I}varName${$NI}. There may be multiple ${$I}key/varName${$NI} pairs. If a ${$I}key${$NI} does not have a - mapping, that corresponds to an unset ${$I}varName${$NI}. When ${$I}body${$NI} terminates, any - changes made to the ${$I}varName${$NI}s is reflected back to the dictionary within - ${$I}dictionaryVariable${$NI} (unless ${$I}dictionaryVariable${$NI} itself becomes unreadable, - when all updates are silently discarded), even if the result of ${$I}body${$NI} is an - error or some other kind of exceptional exit. The result of dict update is - (unless some kind of error occurs) the result of the evaluation of ${$I}body${$NI}. - If ${$I}dictionaryVariable${$NI} indicates an element that does not exist of an array - that has a default value set, the default value and will be used as the - value of the dictionary prior to the update operation. - - Each ${$I}varName${$NI} is mapped in the scope enclosing the dict update; it is - recommended that this command only be used in a local scope (${$B}proc${$N}edure, - lambda term for ${$B}apply${$N}, or method). Because of this, the variables set by - ${$B}dict update${$N} will continue to exist after the command finishes (unless - explicitly unset). - - Note that the mapping of values to variables does not use traces; changes - to the ${$I}dictionaryVariable${$NI}'s contents only happen when ${$I}body${$NI} terminates." - @values -min 4 -max -1 - dictionaryVariable -type string - "key varName" -type {any any} -typesynopsis {${$I}key${$NI} ${$I}varName${$NI}} -optional 0 -multiple 1 - body -type script -typesynopsis ${$I}body