From 87ec3ed13cac112336b474bfabf200e7269ca901 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Sat, 2 Aug 2025 19:49:02 +1000 Subject: [PATCH] update bootsupport in punk project-0.1 template, + minor fixes --- .../punk/mix/commandset/project-0.1.0.tm | 6 + src/make.tcl | 6 +- .../mix/commandset/project-999999.0a1.0.tm | 6 + src/modules/punk/winrun-999999.0a1.0.tm | 161 +- .../custom/_project/punk.basic/src/make.tcl | 6 +- .../punk/mix/commandset/project-0.1.0.tm | 6 + .../_project/punk.project-0.1/src/make.tcl | 6 +- .../punk/mix/commandset/project-0.1.0.tm | 6 + .../_project/punk.shell-0.1/src/make.tcl | 6 +- .../src/bootsupport/lib/base64/ascii85.tcl | 271 + .../src/bootsupport/lib/base64/base64.tcl | 410 + .../src/bootsupport/lib/base64/base64c.tcl | 19 + .../src/bootsupport/lib/base64/pkgIndex.tcl | 5 + .../src/bootsupport/lib/base64/uuencode.tcl | 335 + .../src/bootsupport/lib/base64/yencode.tcl | 307 + .../src/bootsupport/lib/control/ascaller.tcl | 72 + .../src/bootsupport/lib/control/assert.tcl | 91 + .../src/bootsupport/lib/control/control.tcl | 24 + .../src/bootsupport/lib/control/do.tcl | 81 + .../src/bootsupport/lib/control/no-op.tcl | 14 + .../src/bootsupport/lib/control/pkgIndex.tcl | 2 + .../src/bootsupport/lib/control/tclIndex | 18 + .../src/bootsupport/lib/debug/caller.tcl | 97 + .../src/bootsupport/lib/debug/debug.tcl | 306 + .../src/bootsupport/lib/debug/heartbeat.tcl | 68 + .../src/bootsupport/lib/debug/pkgIndex.tcl | 5 + .../src/bootsupport/lib/debug/timestamp.tcl | 47 + .../src/bootsupport/lib/fileutil/decode.tcl | 207 + .../fileutil/fileutil.tcl} | 342 +- .../src/bootsupport/lib/fileutil/multi.tcl | 28 + .../src/bootsupport/lib/fileutil/multiop.tcl | 645 + .../paths-1.tm => lib/fileutil/paths.tcl} | 4 +- .../src/bootsupport/lib/fileutil/pkgIndex.tcl | 7 + .../fileutil/traverse.tcl} | 189 +- .../src/bootsupport/lib/snit/main1.tcl | 3987 ++++++ .../src/bootsupport/lib/snit/main2.tcl | 3888 ++++++ .../src/bootsupport/lib/snit/pkgIndex.tcl | 6 + .../src/bootsupport/lib/snit/snit.tcl | 32 + .../src/bootsupport/lib/snit/snit2.tcl | 32 + .../src/bootsupport/lib/snit/validate.tcl | 720 ++ .../bootsupport/lib/struct/disjointset.tcl | 385 + .../src/bootsupport/lib/struct/graph.tcl | 177 + .../src/bootsupport/lib/struct/graph1.tcl | 2154 ++++ .../src/bootsupport/lib/struct/graph_c.tcl | 158 + .../src/bootsupport/lib/struct/graph_tcl.tcl | 3279 +++++ .../src/bootsupport/lib/struct/graphops.tcl | 3787 ++++++ .../src/bootsupport/lib/struct/list.tcl | 1834 +++ .../src/bootsupport/lib/struct/list.test.tcl | 1268 ++ .../src/bootsupport/lib/struct/map.tcl | 104 + .../src/bootsupport/lib/struct/matrix.tcl | 2806 +++++ .../src/bootsupport/lib/struct/pkgIndex.tcl | 25 + .../src/bootsupport/lib/struct/pool.tcl | 715 ++ .../src/bootsupport/lib/struct/prioqueue.tcl | 535 + .../src/bootsupport/lib/struct/queue.tcl | 183 + .../src/bootsupport/lib/struct/queue_c.tcl | 151 + .../src/bootsupport/lib/struct/queue_oo.tcl | 228 + .../src/bootsupport/lib/struct/queue_tcl.tcl | 383 + .../src/bootsupport/lib/struct/record.tcl | 830 ++ .../src/bootsupport/lib/struct/sets.tcl | 187 + .../src/bootsupport/lib/struct/sets_c.tcl | 91 + .../src/bootsupport/lib/struct/sets_tcl.tcl | 452 + .../src/bootsupport/lib/struct/skiplist.tcl | 437 + .../src/bootsupport/lib/struct/stack.tcl | 183 + .../src/bootsupport/lib/struct/stack_c.tcl | 156 + .../src/bootsupport/lib/struct/stack_oo.tcl | 296 + .../src/bootsupport/lib/struct/stack_tcl.tcl | 505 + .../src/bootsupport/lib/struct/struct.tcl | 18 + .../src/bootsupport/lib/struct/struct1.tcl | 17 + .../src/bootsupport/lib/struct/tree.tcl | 182 + .../src/bootsupport/lib/struct/tree1.tcl | 1485 +++ .../src/bootsupport/lib/struct/tree_c.tcl | 206 + .../src/bootsupport/lib/struct/tree_tcl.tcl | 2442 ++++ .../src/bootsupport/lib/tar/ChangeLog | 186 + .../src/bootsupport/lib/tar/pkgIndex.tcl | 5 + .../src/bootsupport/lib/tar/tar.man | 202 + .../src/bootsupport/lib/tar/tar.pcx | 83 + .../src/bootsupport/lib/tar/tar.tcl | 550 + .../src/bootsupport/lib/tar/tar.test | 139 + .../src/bootsupport/lib/tar/tests/support.tcl | 149 + .../src/bootsupport/lib/term/ansi/code.tcl | 56 + .../bootsupport/lib/term/ansi/code/attr.tcl | 108 + .../bootsupport/lib/term/ansi/code/ctrl.tcl | 272 + .../bootsupport/lib/term/ansi/code/macros.tcl | 93 + .../bootsupport/lib/term/ansi/ctrlunix.tcl | 91 + .../src/bootsupport/lib/term/ansi/send.tcl | 92 + .../src/bootsupport/lib/term/bind.tcl | 132 + .../src/bootsupport/lib/term/imenu.tcl | 202 + .../src/bootsupport/lib/term/ipager.tcl | 206 + .../src/bootsupport/lib/term/pkgIndex.tcl | 13 + .../src/bootsupport/lib/term/receive.tcl | 60 + .../src/bootsupport/lib/term/send.tcl | 34 + .../src/bootsupport/lib/term/term.tcl | 19 + .../src/bootsupport/modules/README.md | 24 + .../modules/argparsingtest-0.1.0.tm | 93 +- .../bootsupport/modules/commandstack-0.3.tm | 6 +- .../src/bootsupport/modules/dictn-0.1.2.tm | 366 + .../{modpod-0.1.2.tm => modpod-0.1.3.tm} | 33 +- .../src/bootsupport/modules/oolib-0.1.tm | 195 + .../{overtype-1.6.5.tm => overtype-1.6.6.tm} | 9 +- .../src/bootsupport/modules/pattern-1.2.4.tm | 304 +- .../src/bootsupport/modules/punk-0.1.tm | 2343 ++-- .../modules/punk/aliascore-0.1.0.tm | 70 +- .../bootsupport/modules/punk/ansi-0.1.1.tm | 1828 ++- .../modules/punk/ansi/colourmap-0.1.0.tm | 966 ++ .../bootsupport/modules/punk/args-0.1.0.tm | 5314 -------- .../src/bootsupport/modules/punk/args-0.2.tm | 10284 ++++++++++++++++ .../modules/punk/args/tclcore-0.1.0.tm | 6539 ++++++++++ .../punk/cap/handlers/templates-0.1.0.tm | 79 +- .../bootsupport/modules/punk/char-0.1.0.tm | 56 +- .../bootsupport/modules/punk/config-0.1.tm | 1155 +- .../bootsupport/modules/punk/console-0.1.1.tm | 31 +- .../bootsupport/modules/punk/docgen-0.1.0.tm | 29 +- .../src/bootsupport/modules/punk/du-0.1.0.tm | 9 +- .../modules/punk/fileline-0.1.0.tm | 4 +- .../src/bootsupport/modules/punk/lib-0.1.0.tm | 1472 --- .../punk/{lib-0.1.1.tm => lib-0.1.2.tm} | 314 +- .../modules/punk/libunknown-0.1.tm | 1776 +++ .../src/bootsupport/modules/punk/mix-0.2.tm | 12 +- .../bootsupport/modules/punk/mix/base-0.1.tm | 15 +- .../bootsupport/modules/punk/mix/cli-0.3.1.tm | 76 +- .../modules/punk/mix/commandset/doc-0.1.0.tm | 8 +- .../punk/mix/commandset/layout-0.1.0.tm | 16 +- .../punk/mix/commandset/loadedlib-0.1.0.tm | 82 +- .../punk/mix/commandset/module-0.1.0.tm | 15 +- .../punk/mix/commandset/project-0.1.0.tm | 147 +- .../modules/punk/mix/commandset/repo-0.1.0.tm | 33 +- .../punk/mix/commandset/scriptwrap-0.1.0.tm | 498 +- .../src/bootsupport/modules/punk/mod-0.1.tm | 325 +- .../bootsupport/modules/punk/nav/fs-0.1.0.tm | 30 +- .../src/bootsupport/modules/punk/ns-0.1.0.tm | 1887 ++- .../bootsupport/modules/punk/overlay-0.1.tm | 30 + .../modules/punk/packagepreference-0.1.0.tm | 159 +- .../bootsupport/modules/punk/path-0.1.0.tm | 180 +- .../src/bootsupport/modules/punk/pipe-1.0.tm | 3 +- .../bootsupport/modules/punk/repl-0.1.2.tm | 3674 ++++++ .../modules/punk/repl/codethread-0.1.1.tm | 8 +- .../bootsupport/modules/punk/repo-0.1.1.tm | 14 +- .../src/bootsupport/modules/punk/zip-0.1.1.tm | 195 +- .../bootsupport/modules/punkcheck-0.1.0.tm | 145 +- .../bootsupport/modules/shellfilter-0.1.9.tm | 161 +- .../bootsupport/modules/shellfilter-0.2.tm | 3317 +++++ .../src/bootsupport/modules/shellrun-0.1.1.tm | 890 ++ .../bootsupport/modules/shellthread-1.6.1.tm | 829 ++ .../bootsupport/modules/test/tomlish-1.1.1.tm | Bin 41364 -> 35259 bytes .../bootsupport/modules/test/tomlish-1.1.3.tm | Bin 0 -> 47064 bytes .../bootsupport/modules/test/tomlish-1.1.5.tm | Bin 0 -> 56588 bytes .../bootsupport/modules/textblock-0.1.3.tm | 673 +- .../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 | 9452 ++++++++++++++ src/scriptapps/jjj.txt | 1 - src/scriptapps/punk87.tcl | 15 - src/vendorlib/icons/icons.tcl | 2 +- .../punk/mix/commandset/project-0.1.0.tm | 6 + .../modules/punk/winrun-0.1.0.tm | 161 +- 155 files changed, 99394 insertions(+), 10955 deletions(-) create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/ascii85.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/base64.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/base64c.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/pkgIndex.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/uuencode.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/yencode.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/ascaller.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/assert.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/control.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/do.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/no-op.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/pkgIndex.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/tclIndex create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/caller.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/debug.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/heartbeat.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/pkgIndex.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/timestamp.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/decode.tcl rename src/project_layouts/vendor/punk/project-0.1/src/bootsupport/{modules/fileutil-1.16.1.tm => lib/fileutil/fileutil.tcl} (85%) create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/multi.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/multiop.tcl rename src/project_layouts/vendor/punk/project-0.1/src/bootsupport/{modules/fileutil/paths-1.tm => lib/fileutil/paths.tcl} (95%) create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/pkgIndex.tcl rename src/project_layouts/vendor/punk/project-0.1/src/bootsupport/{modules/fileutil/traverse-0.6.tm => lib/fileutil/traverse.tcl} (63%) create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/main1.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/main2.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/pkgIndex.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/snit.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/snit2.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/validate.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/disjointset.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graph.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graph1.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graph_c.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graph_tcl.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graphops.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/list.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/list.test.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/map.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/matrix.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/pkgIndex.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/pool.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/prioqueue.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/queue.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/queue_c.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/queue_oo.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/queue_tcl.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/record.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/sets.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/sets_c.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/sets_tcl.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/skiplist.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/stack.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/stack_c.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/stack_oo.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/stack_tcl.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/struct.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/struct1.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/tree.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/tree1.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/tree_c.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/tree_tcl.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/ChangeLog create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/pkgIndex.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tar.man create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tar.pcx create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tar.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tar.test create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tests/support.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/code.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/code/attr.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/code/ctrl.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/code/macros.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/ctrlunix.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/send.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/bind.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/imenu.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ipager.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/pkgIndex.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/receive.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/send.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/term.tcl create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/README.md create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/dictn-0.1.2.tm rename src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/{modpod-0.1.2.tm => modpod-0.1.3.tm} (97%) create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/oolib-0.1.tm rename src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/{overtype-1.6.5.tm => overtype-1.6.6.tm} (99%) create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/args-0.2.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm delete mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/lib-0.1.0.tm rename src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/{lib-0.1.1.tm => lib-0.1.2.tm} (94%) create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/shellfilter-0.2.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/shellrun-0.1.1.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/shellthread-1.6.1.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/test/tomlish-1.1.3.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/test/tomlish-1.1.5.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/tomlish-1.1.4.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/tomlish-1.1.5.tm create mode 100644 src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/tomlish-1.1.6.tm delete mode 100644 src/scriptapps/jjj.txt delete mode 100644 src/scriptapps/punk87.tcl diff --git a/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index d0dd3eb0..4f108187 100644 --- a/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -1117,6 +1117,12 @@ namespace eval punk::mix::commandset::project { #list of repositories of the form repo: #eg repo:C:/Users/someone/.fossils/tcl.fossil + #the command: + # fossil all ignore /repo.fossil + #will remove the {repo:/repo.fossil 1} record from global_config + #but it leaves {ckout: /repo.fossil} records, even if such checkouts are closed + #when the folder itself at is removed - then commands such as 'fossil all ls -c' automatically remove the corresponding ckout: record. + set project_repos [fosconf eval {select name from global_config where name like 'repo:%';}] set paths_and_names [list] foreach pr $project_repos { diff --git a/src/make.tcl b/src/make.tcl index 6ffd6002..fd30f208 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -31,19 +31,19 @@ namespace eval ::punkboot::lib { #for some purposes (whether a source folder is likely to have any useful content) we are interested in non dotfile/dotfolder immediate contents of a folder, but not whether a particular platform #considers them hidden or not. proc folder_nondotted_children {folder} { - if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder 'folder' is not a directory"} + if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder '$folder' is not a directory"} set contents [glob -nocomplain -dir $folder *] #some platforms (windows) return dotted entries with *, although most don't return [lsearch -all -inline -not $contents .*] } proc folder_nondotted_folders {folder} { - if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder 'folder' is not a directory"} + if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder '$folder' is not a directory"} set contents [glob -nocomplain -dir $folder -types d *] #some platforms (windows) return dotted entries with *, although most don't return [lsearch -all -inline -not $contents .*] } proc folder_nondotted_files {folder} { - if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder 'folder' is not a directory"} + if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder '$folder' is not a directory"} set contents [glob -nocomplain -dir $folder -types f $folder *] #some platforms (windows) return dotted entries with *, although most don't return [lsearch -all -inline -not $contents .*] diff --git a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm index 61bd7b75..4b2ae5cf 100644 --- a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm @@ -1117,6 +1117,12 @@ namespace eval punk::mix::commandset::project { #list of repositories of the form repo: #eg repo:C:/Users/someone/.fossils/tcl.fossil + #the command: + # fossil all ignore /repo.fossil + #will remove the {repo:/repo.fossil 1} record from global_config + #but it leaves {ckout: /repo.fossil} records, even if such checkouts are closed + #when the folder itself at is removed - then commands such as 'fossil all ls -c' automatically remove the corresponding ckout: record. + set project_repos [fosconf eval {select name from global_config where name like 'repo:%';}] set paths_and_names [list] foreach pr $project_repos { diff --git a/src/modules/punk/winrun-999999.0a1.0.tm b/src/modules/punk/winrun-999999.0a1.0.tm index 40a8f27e..f24c0cfb 100644 --- a/src/modules/punk/winrun-999999.0a1.0.tm +++ b/src/modules/punk/winrun-999999.0a1.0.tm @@ -42,24 +42,166 @@ namespace eval punk::winrun { while {![chan blocked $chan] && ![eof $chan]} { append data [read $chan 4096] } - puts stdout "-->$data eof:[eof $chan] chan blocked [chan blocked $chan]" + #puts stdout "-->$data eof:[eof $chan] chan blocked [chan blocked $chan]" + puts -nonewline stdout $data flush stdout if {![eof $chan]} { - puts stdout "not eof $chan [fconfigure $chan] chan blocked:[chan blocked $chan]" + #puts stdout "not eof $chan [fconfigure $chan] chan blocked:[chan blocked $chan]" #chan event $chan readable [list punk::winrun::readchild_handler $chan $hpid] } else { - #puts "eof: waiting exit process" - set punk::winrun::waitresult [twapi::wait_on_handle $hpid -wait -1] + puts "eof on out chan $chan" + #set punk::winrun::waitresult [twapi::wait_on_handle $hpid -wait -1] } } - proc readchilderr_handler {chan} { - chan event $chan readable {} - set data [read $chan] - puts stderr "err: $data" + proc readchilderr_handler {chan hpid} { + #chan event $chan readable {} + set data [read $chan 4096] + while {![chan blocked $chan] && ![eof $chan]} { + append data [read $chan 4096] + } + #puts stderr "err: $data" + puts -nonewline stderr $data flush stderr if {![eof $chan]} { - chan event $chan readable [list punk::winrun::readchild_handler $chan] + #chan event $chan readable [list punk::winrun::readchilderr_handler $chan] + } else { + puts "eof on err chan $chan" + } + } + proc stdin_handler {chan hpid} { + set data [read stdin 4096] + #while {![chan blocked stdin] && ![eof stdin]} { + # append data [read stdin 4096] + #} + if {$data ne ""} { + puts -nonewline $chan $data + flush $chan + } + } + proc child_signalled {handle rvalue} { + puts stderr "child_signalled $handle $rvalue" + variable waitresult + set waitresult "child_signalled $handle $rvalue" + } + proc jrun2 {args} { + set cmdline "" + foreach w $args { + append cmdline $w " " + } + set cmdline [string range $cmdline 0 end-1] + package require cffi + cffi::alias load win32 + + cffi::Struct create COORD { + X int + Y int + } + set console_coords [dict create X 80 Y 40] + + + cffi::Wrapper create ::punk::winrun::kernel32 [file join $::env(windir) system32 Kernel32.dll] + #HRESULT WINAPI CreatePseudoConsole( + # _In_ COORD size, + # _In_ HANDLE hInput, + # _In_ HANDLE hOutput, + # _In_ DWORD dwFlags, + # _Out_ HPCON* phPC + #); + #map pointer.HRESULT to int (why?) + cffi::alias define HRESULT {long nonnegative winerror} + kernel32 stdcall CreatePseudoConsole HRESULT { + size struct.COORD + hInput HANDLE + hOutput HANDLE + swFlags DWORD + phPC {pointer.HPCON out} + } + + ::punk::winrun::kernel32 stdcall ClosePseudoConsole void { + hPc pointer.HPCON + } + + #https://learn.microsoft.com/en-us/windows/console/creating-a-pseudoconsole-session + + + + } + variable waitresult + proc jrun {args} { + set cmdline "" + foreach w $args { + append cmdline $w " " } + set cmdline [string range $cmdline 0 end-1] + #inherit stdin from current console + + + #twapi::create_file to redirect? + package require twapi + set cmdid [clock millis] + set childout [twapi::namedpipe_server [string map [list %id% $cmdid ] {//./pipe/tcl-stdout-%id%}] -access write] + set childerr [twapi::namedpipe_server [string map [list %id% $cmdid ] {//./pipe/tcl-stderr-%id%}] -access write] + set childin [twapi::namedpipe_server [string map [list %id% $cmdid ] {//./pipe/tcl-stdin-%id%}] -access read] + #set childin stdin ;#this also works - but not enough for subprocesses to believe they can talk 'terminal' + + + set psinfo [twapi::create_process {} -cmdline $cmdline -returnhandles 1 -detached 0 -newconsole 0 -showwindow hidden -inherithandles 1 -stdchannels [list $childin $childout $childerr]] + puts stdout "psinfo:$psinfo" + lassign $psinfo _pid _tid hpid htid + + set readout [twapi::namedpipe_client [string map [list %id% $cmdid ] {//./pipe/tcl-stdout-%id%}] -access read] + set readerr [twapi::namedpipe_client [string map [list %id% $cmdid ] {//./pipe/tcl-stderr-%id%}] -access read] + set writein [twapi::namedpipe_client [string map [list %id% $cmdid ] {//./pipe/tcl-stdin-%id%}] -access write] + + #after 1000 + chan configure $readout -blocking 0 + chan event $readout readable [list readchild_handler $readout $hpid] + chan configure $readerr -blocking 0 + chan event $readerr readable [list readchilderr_handler $readerr $hpid] + chan configure stdin -blocking 0 + chan event stdin readable [list stdin_handler $writein $hpid] + + #puts stdout "input chan configure: [chan configure $writein]" + #puts $writein "puts stdout blah;" + #flush $writein + #puts $writein "flush stdout" + #flush $writein + #puts $writein "puts exiting" + #puts $writein "after 10;exit 4" + #flush $writein + #puts stdout x--[read $readout] + + #if the cmdline is a pipeline - the wait will return as soon as the first process returns... not the entire pipeline. :/ + #set waitresult [twapi::wait_on_handle $hpid -wait -1] + #set waitresult [twapi::wait_on_handle $hpid -wait 5000] + twapi::wait_on_handle $hpid -async ::punk::winrun::child_signalled + + #temp + #after 5000 {set ::punk::winrun::waitresult timeout} + #e.g timeout, signalled + + #close $childout + #close $childerr + #close $childin + + #after 1 [list wait_on $hpid] + variable waitresult + vwait ::punk::winrun::waitresult + if {$waitresult eq "timeout"} { + puts stderr "jrun: timeout waiting for process" + twapi::end_process $hpid + } + chan event $readout readable {} + chan event $readerr readable {} + chan event stdin readable {} + close $readout + close $readerr + close $writein + + set code [twapi::get_process_exit_code $hpid] + twapi::close_handle $htid + twapi::close_handle $hpid + return [dict create exitcode $code] } proc testrun {cmdline} { @@ -94,6 +236,7 @@ namespace eval punk::winrun { #if the cmdline is a pipeline - the wait will return as soon as the first process returns... not the entire pipeline. :/ #set waitresult [twapi::wait_on_handle $hpid -wait -1] + #set waitresult [twapi::wait_on_handle $hpid -wait 5000] #e.g timeout, signalled close $childout diff --git a/src/project_layouts/custom/_project/punk.basic/src/make.tcl b/src/project_layouts/custom/_project/punk.basic/src/make.tcl index 6ffd6002..fd30f208 100644 --- a/src/project_layouts/custom/_project/punk.basic/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.basic/src/make.tcl @@ -31,19 +31,19 @@ namespace eval ::punkboot::lib { #for some purposes (whether a source folder is likely to have any useful content) we are interested in non dotfile/dotfolder immediate contents of a folder, but not whether a particular platform #considers them hidden or not. proc folder_nondotted_children {folder} { - if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder 'folder' is not a directory"} + if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder '$folder' is not a directory"} set contents [glob -nocomplain -dir $folder *] #some platforms (windows) return dotted entries with *, although most don't return [lsearch -all -inline -not $contents .*] } proc folder_nondotted_folders {folder} { - if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder 'folder' is not a directory"} + if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder '$folder' is not a directory"} set contents [glob -nocomplain -dir $folder -types d *] #some platforms (windows) return dotted entries with *, although most don't return [lsearch -all -inline -not $contents .*] } proc folder_nondotted_files {folder} { - if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder 'folder' is not a directory"} + if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder '$folder' is not a directory"} set contents [glob -nocomplain -dir $folder -types f $folder *] #some platforms (windows) return dotted entries with *, although most don't return [lsearch -all -inline -not $contents .*] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index d0dd3eb0..4f108187 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -1117,6 +1117,12 @@ namespace eval punk::mix::commandset::project { #list of repositories of the form repo: #eg repo:C:/Users/someone/.fossils/tcl.fossil + #the command: + # fossil all ignore /repo.fossil + #will remove the {repo:/repo.fossil 1} record from global_config + #but it leaves {ckout: /repo.fossil} records, even if such checkouts are closed + #when the folder itself at is removed - then commands such as 'fossil all ls -c' automatically remove the corresponding ckout: record. + set project_repos [fosconf eval {select name from global_config where name like 'repo:%';}] set paths_and_names [list] foreach pr $project_repos { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl index 6ffd6002..fd30f208 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl @@ -31,19 +31,19 @@ namespace eval ::punkboot::lib { #for some purposes (whether a source folder is likely to have any useful content) we are interested in non dotfile/dotfolder immediate contents of a folder, but not whether a particular platform #considers them hidden or not. proc folder_nondotted_children {folder} { - if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder 'folder' is not a directory"} + if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder '$folder' is not a directory"} set contents [glob -nocomplain -dir $folder *] #some platforms (windows) return dotted entries with *, although most don't return [lsearch -all -inline -not $contents .*] } proc folder_nondotted_folders {folder} { - if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder 'folder' is not a directory"} + if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder '$folder' is not a directory"} set contents [glob -nocomplain -dir $folder -types d *] #some platforms (windows) return dotted entries with *, although most don't return [lsearch -all -inline -not $contents .*] } proc folder_nondotted_files {folder} { - if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder 'folder' is not a directory"} + if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder '$folder' is not a directory"} set contents [glob -nocomplain -dir $folder -types f $folder *] #some platforms (windows) return dotted entries with *, although most don't return [lsearch -all -inline -not $contents .*] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index d0dd3eb0..4f108187 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -1117,6 +1117,12 @@ namespace eval punk::mix::commandset::project { #list of repositories of the form repo: #eg repo:C:/Users/someone/.fossils/tcl.fossil + #the command: + # fossil all ignore /repo.fossil + #will remove the {repo:/repo.fossil 1} record from global_config + #but it leaves {ckout: /repo.fossil} records, even if such checkouts are closed + #when the folder itself at is removed - then commands such as 'fossil all ls -c' automatically remove the corresponding ckout: record. + set project_repos [fosconf eval {select name from global_config where name like 'repo:%';}] set paths_and_names [list] foreach pr $project_repos { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl index 6ffd6002..fd30f208 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl @@ -31,19 +31,19 @@ namespace eval ::punkboot::lib { #for some purposes (whether a source folder is likely to have any useful content) we are interested in non dotfile/dotfolder immediate contents of a folder, but not whether a particular platform #considers them hidden or not. proc folder_nondotted_children {folder} { - if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder 'folder' is not a directory"} + if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder '$folder' is not a directory"} set contents [glob -nocomplain -dir $folder *] #some platforms (windows) return dotted entries with *, although most don't return [lsearch -all -inline -not $contents .*] } proc folder_nondotted_folders {folder} { - if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder 'folder' is not a directory"} + if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder '$folder' is not a directory"} set contents [glob -nocomplain -dir $folder -types d *] #some platforms (windows) return dotted entries with *, although most don't return [lsearch -all -inline -not $contents .*] } proc folder_nondotted_files {folder} { - if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder 'folder' is not a directory"} + if {![file isdirectory $folder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder '$folder' is not a directory"} set contents [glob -nocomplain -dir $folder -types f $folder *] #some platforms (windows) return dotted entries with *, although most don't return [lsearch -all -inline -not $contents .*] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/ascii85.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/ascii85.tcl new file mode 100644 index 00000000..e05e3430 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/ascii85.tcl @@ -0,0 +1,271 @@ +# ascii85.tcl -- +# +# Encode/Decode ascii85 for a string +# +# Copyright (c) Emiliano Gavilan +# 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.4 + +namespace eval ascii85 { + namespace export encode encodefile decode + # default values for encode options + variable options + array set options [list -wrapchar \n -maxlen 76] +} + +# ::ascii85::encode -- +# +# Ascii85 encode a given string. +# +# Arguments: +# args ?-maxlen maxlen? ?-wrapchar wrapchar? string +# +# If maxlen is 0, the output is not wrapped. +# +# Results: +# A Ascii85 encoded version of $string, wrapped at $maxlen characters +# by $wrapchar. + +proc ascii85::encode {args} { + variable options + + set alen [llength $args] + if {$alen != 1 && $alen != 3 && $alen != 5} { + return -code error "wrong # args:\ + should be \"[lindex [info level 0] 0]\ + ?-maxlen maxlen?\ + ?-wrapchar wrapchar? string\"" + } + + set data [lindex $args end] + array set opts [array get options] + array set opts [lrange $args 0 end-1] + foreach key [array names opts] { + if {[lsearch -exact [array names options] $key] == -1} { + return -code error "unknown option \"$key\":\ + must be -maxlen or -wrapchar" + } + } + + if {![string is integer -strict $opts(-maxlen)] + || $opts(-maxlen) < 0} { + return -code error "expected positive integer but got\ + \"$opts(-maxlen)\"" + } + + # perform this check early + if {[string length $data] == 0} { + return "" + } + + # shorten the names + set ml $opts(-maxlen) + set wc $opts(-wrapchar) + + # if maxlen is zero, don't wrap the output + if {$ml == 0} { + set wc "" + } + + set encoded {} + + binary scan $data c* X + set len [llength $X] + set rest [expr {$len % 4}] + set lastidx [expr {$len - $rest - 1}] + + foreach {b1 b2 b3 b4} [lrange $X 0 $lastidx] { + # calculate the 32 bit value + # this is an inlined version of the [encode4bytes] proc + # included here for performance reasons + set val [expr { + ( (($b1 & 0xff) << 24) + |(($b2 & 0xff) << 16) + |(($b3 & 0xff) << 8) + | ($b4 & 0xff) + ) & 0xffffffff }] + + if {$val == 0} { + # four \0 bytes encodes as "z" instead of "!!!!!" + append current "z" + } else { + # no magic numbers here. + # 52200625 -> 85 ** 4 + # 614125 -> 85 ** 3 + # 7225 -> 85 ** 2 + append current [binary format ccccc \ + [expr { ( $val / 52200625) + 33 }] \ + [expr { (($val % 52200625) / 614125) + 33 }] \ + [expr { (($val % 614125) / 7225) + 33 }] \ + [expr { (($val % 7225) / 85) + 33 }] \ + [expr { ( $val % 85) + 33 }]] + } + + if {[string length $current] >= $ml} { + append encoded [string range $current 0 [expr {$ml - 1}]] $wc + set current [string range $current $ml end] + } + } + + if { $rest } { + # there are remaining bytes. + # pad with \0 and encode not using the "z" convention. + # finally, add ($rest + 1) chars. + set val 0 + foreach {b1 b2 b3 b4} [pad [lrange $X [incr lastidx] end] 4 0] break + append current [string range [encode4bytes $b1 $b2 $b3 $b4] 0 $rest] + } + append encoded [regsub -all -- ".{$ml}" $current "&$wc"] + + return $encoded +} + +proc ascii85::encode4bytes {b1 b2 b3 b4} { + set val [expr { + ( (($b1 & 0xff) << 24) + |(($b2 & 0xff) << 16) + |(($b3 & 0xff) << 8) + | ($b4 & 0xff) + ) & 0xffffffff }] + return [binary format ccccc \ + [expr { ( $val / 52200625) + 33 }] \ + [expr { (($val % 52200625) / 614125) + 33 }] \ + [expr { (($val % 614125) / 7225) + 33 }] \ + [expr { (($val % 7225) / 85) + 33 }] \ + [expr { ( $val % 85) + 33 }]] +} + +# ::ascii85::encodefile -- +# +# Ascii85 encode the contents of a file using default values +# for maxlen and wrapchar parameters. +# +# Arguments: +# fname The name of the file to encode. +# +# Results: +# An Ascii85 encoded version of the contents of the file. +# This is a convenience command + +proc ascii85::encodefile {fname} { + set fd [open $fname] + fconfigure $fd -encoding binary -translation binary + return [encode [read $fd]][close $fd] +} + +# ::ascii85::decode -- +# +# Ascii85 decode a given string. +# +# Arguments: +# string The string to decode. +# Leading spaces and tabs are removed, along with trailing newlines +# +# Results: +# The decoded value. + +proc ascii85::decode {data} { + # get rid of leading spaces/tabs and trailing newlines + set data [string map [list \n {} \t {} { } {}] $data] + set len [string length $data] + + # perform this ckeck early + if {! $len} { + return "" + } + + set decoded {} + set count 0 + set group [list] + binary scan $data c* X + + foreach char $X { + # we must check that every char is in the allowed range + if {$char < 33 || $char > 117 } { + # "z" is an exception + if {$char == 122} { + if {$count == 0} { + # if a "z" char appears at the beggining of a group, + # it decodes as four null bytes + append decoded \x00\x00\x00\x00 + continue + } else { + # if not, is an error + return -code error \ + "error decoding data: \"z\" char misplaced" + } + } + # char is not in range and not a "z" at the beggining of a group + return -code error \ + "error decoding data: chars outside the allowed range" + } + + lappend group $char + incr count + if {$count == 5} { + # this is an inlined version of the [decode5chars] proc + # included here for performance reasons + set val [expr { + ([lindex $group 0] - 33) * wide(52200625) + + ([lindex $group 1] - 33) * 614125 + + ([lindex $group 2] - 33) * 7225 + + ([lindex $group 3] - 33) * 85 + + ([lindex $group 4] - 33) }] + if {$val > 0xffffffff} { + return -code error "error decoding data: decoded group overflow" + } else { + append decoded [binary format I $val] + incr count -5 + set group [list] + } + } + } + + set len [llength $group] + switch -- $len { + 0 { + # all input has been consumed + # do nothing + } + 1 { + # a single char is a condition error, there should be at least 2 + return -code error \ + "error decoding data: trailing char" + } + default { + # pad with "u"s, decode and add ($len - 1) bytes + append decoded [string range \ + [decode5chars [pad $group 5 122]] \ + 0 \ + [expr {$len - 2}]] + } + } + + return $decoded +} + +proc ascii85::decode5chars {group} { + set val [expr { + ([lindex $group 0] - 33) * wide(52200625) + + ([lindex $group 1] - 33) * 614125 + + ([lindex $group 2] - 33) * 7225 + + ([lindex $group 3] - 33) * 85 + + ([lindex $group 4] - 33) }] + if {$val > 0xffffffff} { + return -code error "error decoding data: decoded group overflow" + } + + return [binary format I $val] +} + +proc ascii85::pad {chars len padchar} { + while {[llength $chars] < $len} { + lappend chars $padchar + } + + return $chars +} + +package provide ascii85 1.0 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/base64.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/base64.tcl new file mode 100644 index 00000000..fa52c1c3 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/base64.tcl @@ -0,0 +1,410 @@ +# base64.tcl -- +# +# Encode/Decode base64 for a string +# Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems +# The decoder was done for exmh by Chris Garrigues +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# Version 1.0 implemented Base64_Encode, Base64_Decode +# Version 2.0 uses the base64 namespace +# Version 2.1 fixes various decode bugs and adds options to encode +# Version 2.2 is much faster, Tcl8.0 compatible +# Version 2.2.1 bugfixes +# Version 2.2.2 bugfixes +# Version 2.3 bugfixes and extended to support Trf +# Version 2.4.x bugfixes + +# @mdgen EXCLUDE: base64c.tcl + +package require Tcl 8.2 +namespace eval ::base64 { + namespace export encode decode +} + +package provide base64 2.5 + +if {[package vsatisfies [package require Tcl] 8.6]} { + proc ::base64::encode {args} { + binary encode base64 -maxlen 76 {*}$args + } + + proc ::base64::decode {string} { + # Tcllib is strict with respect to end of input, yet lax for + # invalid characters outside of that. + regsub -all -- {[^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/]} $string {} string + binary decode base64 -strict $string + } + + return +} + +if {![catch {package require Trf 2.0}]} { + # Trf is available, so implement the functionality provided here + # in terms of calls to Trf for speed. + + # ::base64::encode -- + # + # Base64 encode a given string. + # + # Arguments: + # args ?-maxlen maxlen? ?-wrapchar wrapchar? string + # + # If maxlen is 0, the output is not wrapped. + # + # Results: + # A Base64 encoded version of $string, wrapped at $maxlen characters + # by $wrapchar. + + proc ::base64::encode {args} { + # Set the default wrapchar and maximum line length to match + # the settings for MIME encoding (RFC 3548, RFC 2045). These + # are the settings used by Trf as well. Various RFCs allow for + # different wrapping characters and wraplengths, so these may + # be overridden by command line options. + set wrapchar "\n" + set maxlen 76 + + if { [llength $args] == 0 } { + error "wrong # args: should be \"[lindex [info level 0] 0]\ + ?-maxlen maxlen? ?-wrapchar wrapchar? string\"" + } + + set optionStrings [list "-maxlen" "-wrapchar"] + for {set i 0} {$i < [llength $args] - 1} {incr i} { + set arg [lindex $args $i] + set index [lsearch -glob $optionStrings "${arg}*"] + if { $index == -1 } { + error "unknown option \"$arg\": must be -maxlen or -wrapchar" + } + incr i + if { $i >= [llength $args] - 1 } { + error "value for \"$arg\" missing" + } + set val [lindex $args $i] + + # The name of the variable to assign the value to is extracted + # from the list of known options, all of which have an + # associated variable of the same name as the option without + # a leading "-". The [string range] command is used to strip + # of the leading "-" from the name of the option. + # + # FRINK: nocheck + set [string range [lindex $optionStrings $index] 1 end] $val + } + + # [string is] requires Tcl8.2; this works with 8.0 too + if {[catch {expr {$maxlen % 2}}]} { + return -code error "expected integer but got \"$maxlen\"" + } elseif {$maxlen < 0} { + return -code error "expected positive integer but got \"$maxlen\"" + } + + set string [lindex $args end] + set result [::base64 -mode encode -- $string] + + # Trf's encoder implicitly uses the settings -maxlen 76, + # -wrapchar \n for its output. We may have to reflow this for + # the settings chosen by the user. A second difference is that + # Trf closes the output with the wrap char sequence, + # always. The code here doesn't. Therefore 'trimright' is + # needed in the fast cases. + + if {($maxlen == 76) && [string equal $wrapchar \n]} { + # Both maxlen and wrapchar are identical to Trf's + # settings. This is the super-fast case, because nearly + # nothing has to be done. Only thing to do is strip a + # terminating wrapchar. + set result [string trimright $result] + } elseif {$maxlen == 76} { + # wrapchar has to be different here, length is the + # same. We can use 'string map' to transform the wrap + # information. + set result [string map [list \n $wrapchar] \ + [string trimright $result]] + } elseif {$maxlen == 0} { + # Have to reflow the output to no wrapping. Another fast + # case using only 'string map'. 'trimright' is not needed + # here. + + set result [string map [list \n ""] $result] + } else { + # Have to reflow the output from 76 to the chosen maxlen, + # and possibly change the wrap sequence as well. + + # Note: After getting rid of the old wrap sequence we + # extract the relevant segments from the string without + # modifying the string. Modification, i.e. removal of the + # processed part, means 'shifting down characters in + # memory', making the algorithm O(n^2). By avoiding the + # modification we stay in O(n). + + set result [string map [list \n ""] $result] + set l [expr {[string length $result]-$maxlen}] + for {set off 0} {$off < $l} {incr off $maxlen} { + append res [string range $result $off [expr {$off+$maxlen-1}]] $wrapchar + } + append res [string range $result $off end] + set result $res + } + + return $result + } + + # ::base64::decode -- + # + # Base64 decode a given string. + # + # Arguments: + # string The string to decode. Characters not in the base64 + # alphabet are ignored (e.g., newlines) + # + # Results: + # The decoded value. + + proc ::base64::decode {string} { + regsub -all {\s} $string {} string + ::base64 -mode decode -- $string + } + +} else { + # Without Trf use a pure tcl implementation + + namespace eval base64 { + variable base64 {} + variable base64_en {} + + # We create the auxiliary array base64_tmp, it will be unset later. + variable base64_tmp + variable i + + set i 0 + foreach char {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 base64_tmp($char) $i + lappend base64_en $char + incr i + } + + # + # Create base64 as list: to code for instance C<->3, specify + # that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded + # ascii chars get a {}. we later use the fact that lindex on a + # non-existing index returns {}, and that [expr {} < 0] is true + # + + # the last ascii char is 'z' + variable char + variable len + variable val + + scan z %c len + for {set i 0} {$i <= $len} {incr i} { + set char [format %c $i] + set val {} + if {[info exists base64_tmp($char)]} { + set val $base64_tmp($char) + } else { + set val {} + } + lappend base64 $val + } + + # code the character "=" as -1; used to signal end of message + scan = %c i + set base64 [lreplace $base64 $i $i -1] + + # remove unneeded variables + unset base64_tmp i char len val + + namespace export encode decode + } + + # ::base64::encode -- + # + # Base64 encode a given string. + # + # Arguments: + # args ?-maxlen maxlen? ?-wrapchar wrapchar? string + # + # If maxlen is 0, the output is not wrapped. + # + # Results: + # A Base64 encoded version of $string, wrapped at $maxlen characters + # by $wrapchar. + + proc ::base64::encode {args} { + set base64_en $::base64::base64_en + + # Set the default wrapchar and maximum line length to match + # the settings for MIME encoding (RFC 3548, RFC 2045). These + # are the settings used by Trf as well. Various RFCs allow for + # different wrapping characters and wraplengths, so these may + # be overridden by command line options. + set wrapchar "\n" + set maxlen 76 + + if { [llength $args] == 0 } { + error "wrong # args: should be \"[lindex [info level 0] 0]\ + ?-maxlen maxlen? ?-wrapchar wrapchar? string\"" + } + + set optionStrings [list "-maxlen" "-wrapchar"] + for {set i 0} {$i < [llength $args] - 1} {incr i} { + set arg [lindex $args $i] + set index [lsearch -glob $optionStrings "${arg}*"] + if { $index == -1 } { + error "unknown option \"$arg\": must be -maxlen or -wrapchar" + } + incr i + if { $i >= [llength $args] - 1 } { + error "value for \"$arg\" missing" + } + set val [lindex $args $i] + + # The name of the variable to assign the value to is extracted + # from the list of known options, all of which have an + # associated variable of the same name as the option without + # a leading "-". The [string range] command is used to strip + # of the leading "-" from the name of the option. + # + # FRINK: nocheck + set [string range [lindex $optionStrings $index] 1 end] $val + } + + # [string is] requires Tcl8.2; this works with 8.0 too + if {[catch {expr {$maxlen % 2}}]} { + return -code error "expected integer but got \"$maxlen\"" + } elseif {$maxlen < 0} { + return -code error "expected positive integer but got \"$maxlen\"" + } + + set string [lindex $args end] + + set result {} + set state 0 + set length 0 + + + # Process the input bytes 3-by-3 + + binary scan $string c* X + + foreach {x y z} $X { + ADD [lindex $base64_en [expr {($x >>2) & 0x3F}]] + if {$y != {}} { + ADD [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] + if {$z != {}} { + ADD [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]] + ADD [lindex $base64_en [expr {($z & 0x3F)}]] + } else { + set state 2 + break + } + } else { + set state 1 + break + } + } + if {$state == 1} { + ADD [lindex $base64_en [expr {(($x << 4) & 0x30)}]] + ADD = + ADD = + } elseif {$state == 2} { + ADD [lindex $base64_en [expr {(($y << 2) & 0x3C)}]] + ADD = + } + return $result + } + + proc ::base64::ADD {x} { + # The line length check is always done before appending so + # that we don't get an extra newline if the output is a + # multiple of $maxlen chars long. + + upvar 1 maxlen maxlen length length result result wrapchar wrapchar + if {$maxlen && $length >= $maxlen} { + append result $wrapchar + set length 0 + } + append result $x + incr length + return + } + + # ::base64::decode -- + # + # Base64 decode a given string. + # + # Arguments: + # string The string to decode. Characters not in the base64 + # alphabet are ignored (e.g., newlines) + # + # Results: + # The decoded value. + + proc ::base64::decode {string} { + if {[string length $string] == 0} {return ""} + + set base64 $::base64::base64 + set output "" ; # Fix for [Bug 821126] + set nums {} + + binary scan $string c* X + lappend X 61 ;# force a terminator + foreach x $X { + set bits [lindex $base64 $x] + if {$bits >= 0} { + if {[llength [lappend nums $bits]] == 4} { + foreach {v w z y} $nums break + set a [expr {($v << 2) | ($w >> 4)}] + set b [expr {(($w & 0xF) << 4) | ($z >> 2)}] + set c [expr {(($z & 0x3) << 6) | $y}] + append output [binary format ccc $a $b $c] + set nums {} + } + } elseif {$bits == -1} { + # = indicates end of data. Output whatever chars are + # left, if any. + if {![llength $nums]} break + # The encoding algorithm dictates that we can only + # have 1 or 2 padding characters. If x=={}, we must + # (*) have 12 bits of input (enough for 1 8-bit + # output). If x!={}, we have 18 bits of input (enough + # for 2 8-bit outputs). + # + # (*) If we don't then the input is broken (bug 2976290). + + foreach {v w z} $nums break + + # Bug 2976290 + if {$w == {}} { + return -code error "Not enough data to process padding" + } + + set a [expr {($v << 2) | (($w & 0x30) >> 4)}] + if {$z == {}} { + append output [binary format c $a ] + } else { + set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}] + append output [binary format cc $a $b] + } + break + } else { + # RFC 2045 says that line breaks and other characters not part + # of the Base64 alphabet must be ignored, and that the decoder + # can optionally emit a warning or reject the message. We opt + # not to do so, but to just ignore the character. + continue + } + } + return $output + } +} + +# # ## ### ##### ######## ############# ##################### +return + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/base64c.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/base64c.tcl new file mode 100644 index 00000000..29e501df --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/base64c.tcl @@ -0,0 +1,19 @@ +# base64c - Copyright (C) 2003 Pat Thoyts +# +# This package is a place-holder for the critcl enhanced code present in +# the tcllib base64 module. +# +# Normally this code will become part of the tcllibc library. +# + +# @sak notprovided base64c +package require critcl +package provide base64c 0.1.0 + +namespace eval ::base64c { + variable base64c_rcsid {$Id: base64c.tcl,v 1.5 2008/03/25 07:15:35 andreas_kupries Exp $} + + critcl::ccode { + /* no code required in this file */ + } +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/pkgIndex.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/pkgIndex.tcl new file mode 100644 index 00000000..c8528f59 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/pkgIndex.tcl @@ -0,0 +1,5 @@ +if {![package vsatisfies [package provide Tcl] 8.2]} {return} +package ifneeded base64 2.5 [list source [file join $dir base64.tcl]] +package ifneeded uuencode 1.1.5 [list source [file join $dir uuencode.tcl]] +package ifneeded yencode 1.1.3 [list source [file join $dir yencode.tcl]] +package ifneeded ascii85 1.0 [list source [file join $dir ascii85.tcl]] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/uuencode.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/uuencode.tcl new file mode 100644 index 00000000..5e26422d --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/uuencode.tcl @@ -0,0 +1,335 @@ +# uuencode - Copyright (C) 2002 Pat Thoyts +# +# Provide a Tcl only implementation of uuencode and uudecode. +# +# ------------------------------------------------------------------------- +# 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 + +# Try and get some compiled helper package. +if {[catch {package require tcllibc}]} { + catch {package require Trf} +} + +namespace eval ::uuencode { + namespace export encode decode uuencode uudecode +} + +proc ::uuencode::Enc {c} { + return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]] +} + +proc ::uuencode::Encode {s} { + set r {} + binary scan $s c* d + foreach {c1 c2 c3} $d { + if {$c1 == {}} {set c1 0} + if {$c2 == {}} {set c2 0} + if {$c3 == {}} {set c3 0} + append r [Enc [expr {$c1 >> 2}]] + append r [Enc [expr {(($c1 << 4) & 060) | (($c2 >> 4) & 017)}]] + append r [Enc [expr {(($c2 << 2) & 074) | (($c3 >> 6) & 003)}]] + append r [Enc [expr {($c3 & 077)}]] + } + return $r +} + + +proc ::uuencode::Decode {s} { + if {[string length $s] == 0} {return ""} + set r {} + binary scan [pad $s] c* d + + foreach {c0 c1 c2 c3} $d { + append r [format %c [expr {((($c0-0x20)&0x3F) << 2) & 0xFF + | ((($c1-0x20)&0x3F) >> 4) & 0xFF}]] + append r [format %c [expr {((($c1-0x20)&0x3F) << 4) & 0xFF + | ((($c2-0x20)&0x3F) >> 2) & 0xFF}]] + append r [format %c [expr {((($c2-0x20)&0x3F) << 6) & 0xFF + | (($c3-0x20)&0x3F) & 0xFF}]] + } + return $r +} + +# ------------------------------------------------------------------------- +# C coded version of the Encode/Decode functions for base64c package. +# ------------------------------------------------------------------------- +if {[package provide critcl] != {}} { + namespace eval ::uuencode { + critcl::ccode { + #include + static unsigned char Enc(unsigned char c) { + return (c != 0) ? ((c & 0x3f) + 0x20) : 0x60; + } + } + critcl::ccommand CEncode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, xtra; + unsigned char *input, *p, *r; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + if ((xtra = (3 - (len % 3))) != 3) { + if (Tcl_IsShared(inputPtr)) + inputPtr = Tcl_DuplicateObj(inputPtr); + input = Tcl_SetByteArrayLength(inputPtr, len + xtra); + memset(input + len, 0, xtra); + len += xtra; + } + + rlen = (len / 3) * 4; + resultPtr = Tcl_NewObj(); + r = Tcl_SetByteArrayLength(resultPtr, rlen); + memset(r, 0, rlen); + + for (p = input; p < input + len; p += 3) { + char a, b, c; + a = *p; b = *(p+1), c = *(p+2); + *r++ = Enc(a >> 2); + *r++ = Enc(((a << 4) & 060) | ((b >> 4) & 017)); + *r++ = Enc(((b << 2) & 074) | ((c >> 6) & 003)); + *r++ = Enc(c & 077); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + critcl::ccommand CDecode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, xtra; + unsigned char *input, *p, *r; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + /* if input is not mod 4, extend it with nuls */ + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + if ((xtra = (4 - (len % 4))) != 4) { + if (Tcl_IsShared(inputPtr)) + inputPtr = Tcl_DuplicateObj(inputPtr); + input = Tcl_SetByteArrayLength(inputPtr, len + xtra); + memset(input + len, 0, xtra); + len += xtra; + } + + /* output will be 1/3 smaller than input and a multiple of 3 */ + rlen = (len / 4) * 3; + resultPtr = Tcl_NewObj(); + r = Tcl_SetByteArrayLength(resultPtr, rlen); + memset(r, 0, rlen); + + for (p = input; p < input + len; p += 4) { + char a, b, c, d; + a = *p; b = *(p+1), c = *(p+2), d = *(p+3); + *r++ = (((a - 0x20) & 0x3f) << 2) | (((b - 0x20) & 0x3f) >> 4); + *r++ = (((b - 0x20) & 0x3f) << 4) | (((c - 0x20) & 0x3f) >> 2); + *r++ = (((c - 0x20) & 0x3f) << 6) | (((d - 0x20) & 0x3f) ); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + } +} + +# ------------------------------------------------------------------------- + +# Description: +# Permit more tolerant decoding of invalid input strings by padding to +# a multiple of 4 bytes with nulls. +# Result: +# Returns the input string - possibly padded with uuencoded null chars. +# +proc ::uuencode::pad {s} { + if {[set mod [expr {[string length $s] % 4}]] != 0} { + append s [string repeat "`" [expr {4 - $mod}]] + } + return $s +} + +# ------------------------------------------------------------------------- + +# If the Trf package is available then we shall use this by default but the +# Tcllib implementations are always visible if needed (ie: for testing) +if {[info commands ::uuencode::CDecode] != {}} { + # tcllib critcl package + interp alias {} ::uuencode::encode {} ::uuencode::CEncode + interp alias {} ::uuencode::decode {} ::uuencode::CDecode +} elseif {[package provide Trf] != {}} { + proc ::uuencode::encode {s} { + return [::uuencode -mode encode -- $s] + } + proc ::uuencode::decode {s} { + return [::uuencode -mode decode -- [pad $s]] + } +} else { + # pure-tcl then + interp alias {} ::uuencode::encode {} ::uuencode::Encode + interp alias {} ::uuencode::decode {} ::uuencode::Decode +} + +# ------------------------------------------------------------------------- + +proc ::uuencode::uuencode {args} { + array set opts {mode 0644 filename {} name {}} + set wrongargs "wrong \# args: should be\ + \"uuencode ?-name string? ?-mode octal?\ + (-file filename | ?--? string)\"" + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { + if {[llength $args] < 2} { + return -code error $wrongargs + } + set opts(filename) [lindex $args 1] + set args [lreplace $args 0 0] + } + -m* { + if {[llength $args] < 2} { + return -code error $wrongargs + } + set opts(mode) [lindex $args 1] + set args [lreplace $args 0 0] + } + -n* { + if {[llength $args] < 2} { + return -code error $wrongargs + } + set opts(name) [lindex $args 1] + set args [lreplace $args 0 0] + } + -- { + set args [lreplace $args 0 0] + break + } + default { + return -code error "bad option [lindex $args 0]:\ + must be -file, -mode, or -name" + } + } + set args [lreplace $args 0 0] + } + + if {$opts(name) == {}} { + set opts(name) $opts(filename) + } + if {$opts(name) == {}} { + set opts(name) "data.dat" + } + + if {$opts(filename) != {}} { + set f [open $opts(filename) r] + fconfigure $f -translation binary + set data [read $f] + close $f + } else { + if {[llength $args] != 1} { + return -code error $wrongargs + } + set data [lindex $args 0] + } + + set r {} + append r [format "begin %o %s" $opts(mode) $opts(name)] "\n" + for {set n 0} {$n < [string length $data]} {incr n 45} { + set s [string range $data $n [expr {$n + 44}]] + append r [Enc [string length $s]] + append r [encode $s] "\n" + } + append r "`\nend" + return $r +} + +# ------------------------------------------------------------------------- +# Description: +# Perform uudecoding of a file or data. A file may contain more than one +# encoded data section so the result is a list where each element is a +# three element list of the provided filename, the suggested mode and the +# data itself. +# +proc ::uuencode::uudecode {args} { + array set opts {mode 0644 filename {}} + set wrongargs "wrong \# args: should be \"uudecode (-file filename | ?--? string)\"" + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { + if {[llength $args] < 2} { + return -code error $wrongargs + } + set opts(filename) [lindex $args 1] + set args [lreplace $args 0 0] + } + -- { + set args [lreplace $args 0 0] + break + } + default { + return -code error "bad option [lindex $args 0]:\ + must be -file" + } + } + set args [lreplace $args 0 0] + } + + if {$opts(filename) != {}} { + set f [open $opts(filename) r] + set data [read $f] + close $f + } else { + if {[llength $args] != 1} { + return -code error $wrongargs + } + set data [lindex $args 0] + } + + set state false + set result {} + + foreach {line} [split $data "\n"] { + switch -exact -- $state { + false { + if {[regexp {^begin ([0-7]+) ([^\s]*)} $line \ + -> opts(mode) opts(name)]} { + set state true + set r {} + } + } + + true { + if {[string match "end" $line]} { + set state false + lappend result [list $opts(name) $opts(mode) $r] + } else { + scan $line %c c + set n [expr {($c - 0x21)}] + append r [string range \ + [decode [string range $line 1 end]] 0 $n] + } + } + } + } + + return $result +} + +# ------------------------------------------------------------------------- + +package provide uuencode 1.1.5 + +# ------------------------------------------------------------------------- +# +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/yencode.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/yencode.tcl new file mode 100644 index 00000000..0d4554c0 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/base64/yencode.tcl @@ -0,0 +1,307 @@ +# yencode.tcl - Copyright (C) 2002 Pat Thoyts +# +# Provide a Tcl only implementation of yEnc encoding algorithm +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- + +# FUTURE: Rework to allow switching between the tcl/critcl implementations. + +package require Tcl 8.2; # tcl minimum version +catch {package require crc32}; # tcllib 1.1 +catch {package require tcllibc}; # critcl enhancements for tcllib + +namespace eval ::yencode { + namespace export encode decode yencode ydecode +} + +# ------------------------------------------------------------------------- + +proc ::yencode::Encode {s} { + set r {} + binary scan $s c* d + foreach {c} $d { + set v [expr {($c + 42) % 256}] + if {$v == 0x00 || $v == 0x09 || $v == 0x0A + || $v == 0x0D || $v == 0x3D} { + append r "=" + set v [expr {($v + 64) % 256}] + } + append r [format %c $v] + } + return $r +} + +proc ::yencode::Decode {s} { + if {[string length $s] == 0} {return ""} + set r {} + set esc 0 + binary scan $s c* d + foreach c $d { + if {$c == 61 && $esc == 0} { + set esc 1 + continue + } + set v [expr {($c - 42) % 256}] + if {$esc} { + set v [expr {($v - 64) % 256}] + set esc 0 + } + append r [format %c $v] + } + return $r +} + +# ------------------------------------------------------------------------- +# C coded versions for critcl built base64c package +# ------------------------------------------------------------------------- + +if {[package provide critcl] != {}} { + namespace eval ::yencode { + critcl::ccode { + #include + } + critcl::ccommand CEncode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, xtra; + unsigned char *input, *p, *r, v; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + /* fetch the input data */ + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + + /* calculate the length of the encoded result */ + rlen = len; + for (p = input; p < input + len; p++) { + v = (*p + 42) % 256; + if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) + rlen++; + } + + /* allocate the output buffer */ + resultPtr = Tcl_NewObj(); + r = Tcl_SetByteArrayLength(resultPtr, rlen); + + /* encode the input */ + for (p = input; p < input + len; p++) { + v = (*p + 42) % 256; + if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) { + *r++ = '='; + v = (v + 64) % 256; + } + *r++ = v; + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + critcl::ccommand CDecode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, esc; + unsigned char *input, *p, *r, v; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + /* fetch the input data */ + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + + /* allocate the output buffer */ + resultPtr = Tcl_NewObj(); + r = Tcl_SetByteArrayLength(resultPtr, len); + + /* encode the input */ + for (p = input, esc = 0, rlen = 0; p < input + len; p++) { + if (*p == 61 && esc == 0) { + esc = 1; + continue; + } + v = (*p - 42) % 256; + if (esc) { + v = (v - 64) % 256; + esc = 0; + } + *r++ = v; + rlen++; + } + Tcl_SetByteArrayLength(resultPtr, rlen); + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + } +} + +if {[info commands ::yencode::CEncode] != {}} { + interp alias {} ::yencode::encode {} ::yencode::CEncode + interp alias {} ::yencode::decode {} ::yencode::CDecode +} else { + interp alias {} ::yencode::encode {} ::yencode::Encode + interp alias {} ::yencode::decode {} ::yencode::Decode +} + +# ------------------------------------------------------------------------- +# Description: +# Pop the nth element off a list. Used in options processing. +# +proc ::yencode::Pop {varname {nth 0}} { + upvar $varname args + set r [lindex $args $nth] + set args [lreplace $args $nth $nth] + return $r +} + +# ------------------------------------------------------------------------- + +proc ::yencode::yencode {args} { + array set opts {mode 0644 filename {} name {} line 128 crc32 1} + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { set opts(filename) [Pop args 1] } + -m* { set opts(mode) [Pop args 1] } + -n* { set opts(name) [Pop args 1] } + -l* { set opts(line) [Pop args 1] } + -c* { set opts(crc32) [Pop args 1] } + -- { Pop args ; break } + default { + set options [join [lsort [array names opts]] ", -"] + return -code error "bad option [lindex $args 0]:\ + must be -$options" + } + } + Pop args + } + + if {$opts(name) == {}} { + set opts(name) $opts(filename) + } + if {$opts(name) == {}} { + set opts(name) "data.dat" + } + if {! [string is boolean $opts(crc32)]} { + return -code error "bad option -crc32: argument must be true or false" + } + + if {$opts(filename) != {}} { + set f [open $opts(filename) r] + fconfigure $f -translation binary + set data [read $f] + close $f + } else { + if {[llength $args] != 1} { + return -code error "wrong \# args: should be\ + \"yencode ?options? -file name | data\"" + } + set data [lindex $args 0] + } + + set opts(size) [string length $data] + + set r {} + append r [format "=ybegin line=%d size=%d name=%s" \ + $opts(line) $opts(size) $opts(name)] "\n" + + set ndx 0 + while {$ndx < $opts(size)} { + set pln [string range $data $ndx [expr {$ndx + $opts(line) - 1}]] + set enc [encode $pln] + incr ndx [string length $pln] + append r $enc "\r\n" + } + + append r [format "=yend size=%d" $ndx] + if {$opts(crc32)} { + append r " crc32=" [crc::crc32 -format %x $data] + } + return $r +} + +# ------------------------------------------------------------------------- +# Description: +# Perform ydecoding of a file or data. A file may contain more than one +# encoded data section so the result is a list where each element is a +# three element list of the provided filename, the file size and the +# data itself. +# +proc ::yencode::ydecode {args} { + array set opts {mode 0644 filename {} name default.bin} + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { set opts(filename) [Pop args 1] } + -- { Pop args ; break; } + default { + set options [join [lsort [array names opts]] ", -"] + return -code error "bad option [lindex $args 0]:\ + must be -$opts" + } + } + Pop args + } + + if {$opts(filename) != {}} { + set f [open $opts(filename) r] + set data [read $f] + close $f + } else { + if {[llength $args] != 1} { + return -code error "wrong \# args: should be\ + \"ydecode ?options? -file name | data\"" + } + set data [lindex $args 0] + } + + set state false + set result {} + + foreach {line} [split $data "\n"] { + set line [string trimright $line "\r\n"] + switch -exact -- $state { + false { + if {[string match "=ybegin*" $line]} { + regexp {line=(\d+)} $line -> opts(line) + regexp {size=(\d+)} $line -> opts(size) + regexp {name=(\d+)} $line -> opts(name) + + if {$opts(name) == {}} { + set opts(name) default.bin + } + + set state true + set r {} + } + } + + true { + if {[string match "=yend*" $line]} { + set state false + lappend result [list $opts(name) $opts(size) $r] + } else { + append r [decode $line] + } + } + } + } + + return $result +} + +# ------------------------------------------------------------------------- + +package provide yencode 1.1.3 + +# ------------------------------------------------------------------------- +# +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/ascaller.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/ascaller.tcl new file mode 100644 index 00000000..6c864bb5 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/ascaller.tcl @@ -0,0 +1,72 @@ +# ascaller.tcl - +# +# A few utility procs that manage the evaluation of a command +# or a script in the context of a caller, taking care of all +# the ugly details of proper return codes, errorcodes, and +# a good stack trace in ::errorInfo as appropriate. +# ------------------------------------------------------------------------- +# +# RCS: @(#) $Id: ascaller.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $ + +namespace eval ::control { + + proc CommandAsCaller {cmdVar resultVar {where {}} {codeVar code}} { + set x [expr {[string equal "" $where] + ? {} : [subst -nobackslashes {\n ($where)}]}] + set script [subst -nobackslashes -nocommands { + set $codeVar [catch {uplevel 1 $$cmdVar} $resultVar] + if {$$codeVar > 1} { + return -code $$codeVar $$resultVar + } + if {$$codeVar == 1} { + if {[string equal {"uplevel 1 $$cmdVar"} \ + [lindex [split [set ::errorInfo] \n] end]]} { + set $codeVar [join \ + [lrange [split [set ::errorInfo] \n] 0 \ + end-[expr {4+[llength [split $$cmdVar \n]]}]] \n] + } else { + set $codeVar [join \ + [lrange [split [set ::errorInfo] \n] 0 end-1] \n] + } + return -code error -errorcode [set ::errorCode] \ + -errorinfo "$$codeVar$x" $$resultVar + } + }] + return $script + } + + proc BodyAsCaller {bodyVar resultVar codeVar {where {}}} { + set x [expr {[string equal "" $where] + ? {} : [subst -nobackslashes -nocommands \ + {\n ($where[string map {{ ("uplevel"} {}} \ + [lindex [split [set ::errorInfo] \n] end]]}]}] + set script [subst -nobackslashes -nocommands { + set $codeVar [catch {uplevel 1 $$bodyVar} $resultVar] + if {$$codeVar == 1} { + if {[string equal {"uplevel 1 $$bodyVar"} \ + [lindex [split [set ::errorInfo] \n] end]]} { + set ::errorInfo [join \ + [lrange [split [set ::errorInfo] \n] 0 end-2] \n] + } + set $codeVar [join \ + [lrange [split [set ::errorInfo] \n] 0 end-1] \n] + return -code error -errorcode [set ::errorCode] \ + -errorinfo "$$codeVar$x" $$resultVar + } + }] + return $script + } + + proc ErrorInfoAsCaller {find replace} { + set info $::errorInfo + set i [string last "\n (\"$find" $info] + if {$i == -1} {return $info} + set result [string range $info 0 [incr i 6]] ;# keep "\n (\"" + append result $replace ;# $find -> $replace + incr i [string length $find] + set j [string first ) $info [incr i]] ;# keep rest of parenthetical + append result [string range $info $i $j] + return $result + } + +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/assert.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/assert.tcl new file mode 100644 index 00000000..8aac408d --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/assert.tcl @@ -0,0 +1,91 @@ +# assert.tcl -- +# +# The [assert] command of the package "control". +# +# RCS: @(#) $Id: assert.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $ + +namespace eval ::control { + + namespace eval assert { + namespace export EnabledAssert DisabledAssert + variable CallbackCmd [list return -code error] + + namespace import [namespace parent]::no-op + rename no-op DisabledAssert + + proc EnabledAssert {expr args} { + variable CallbackCmd + + set code [catch {uplevel 1 [list expr $expr]} res] + if {$code} { + return -code $code $res + } + if {![string is boolean -strict $res]} { + return -code error "invalid boolean expression: $expr" + } + if {$res} {return} + if {[llength $args]} { + set msg [join $args] + } else { + set msg "assertion failed: $expr" + } + # Might want to catch this + namespace eval :: $CallbackCmd [list $msg] + } + + proc enabled {args} { + set n [llength $args] + if {$n > 1} { + return -code error "wrong # args: should be\ + \"[lindex [info level 0] 0] ?boolean?\"" + } + if {$n} { + set val [lindex $args 0] + if {![string is boolean -strict $val]} { + return -code error "invalid boolean value: $val" + } + if {$val} { + [namespace parent]::AssertSwitch Disabled Enabled + } else { + [namespace parent]::AssertSwitch Enabled Disabled + } + } else { + return [string equal [namespace origin EnabledAssert] \ + [namespace origin [namespace parent]::assert]] + } + return "" + } + + proc callback {args} { + set n [llength $args] + if {$n > 1} { + return -code error "wrong # args: should be\ + \"[lindex [info level 0] 0] ?command?\"" + } + if {$n} { + return [variable CallbackCmd [lindex $args 0]] + } + variable CallbackCmd + return $CallbackCmd + } + + } + + proc AssertSwitch {old new} { + if {[string equal [namespace origin assert] \ + [namespace origin assert::${new}Assert]]} {return} + rename assert ${old}Assert + rename ${new}Assert assert + } + + namespace import assert::DisabledAssert assert::EnabledAssert + + # For indexer + proc assert args # + rename assert {} + + # Initial default: disabled asserts + rename DisabledAssert assert + +} + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/control.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/control.tcl new file mode 100644 index 00000000..372f8ac1 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/control.tcl @@ -0,0 +1,24 @@ +# control.tcl -- +# +# This is the main package provide script for the package +# "control". It provides commands that govern the flow of +# control of a program. + +package require Tcl 8.5 9 + +namespace eval ::control { + namespace export assert control do no-op rswitch + + proc control {command args} { + # Need to add error handling here + namespace eval [list $command] $args + } + + # Set up for auto-loading the commands + variable home [file join [pwd] [file dirname [info script]]] + if {[lsearch -exact $::auto_path $home] == -1} { + lappend ::auto_path $home + } + + package provide [namespace tail [namespace current]] 0.1.4 +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/do.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/do.tcl new file mode 100644 index 00000000..aa5c1af5 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/do.tcl @@ -0,0 +1,81 @@ +# do.tcl -- +# +# Tcl implementation of a "do ... while|until" loop. +# +# Originally written for the "Texas Tcl Shootout" programming contest +# at the 2000 Tcl Conference in Austin/Texas. +# +# Copyright (c) 2001 by Reinhard Max +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: do.tcl,v 1.6 2004/01/15 06:36:12 andreas_kupries Exp $ +# +namespace eval ::control { + + proc do {body args} { + + # + # Implements a "do body while|until test" loop + # + # It is almost as fast as builtin "while" command for loops with + # more than just a few iterations. + # + + set len [llength $args] + if {$len !=2 && $len != 0} { + set proc [namespace current]::[lindex [info level 0] 0] + return -code error "wrong # args: should be \"$proc body\" or \"$proc body \[until|while\] test\"" + } + set test 0 + foreach {whileOrUntil test} $args { + switch -exact -- $whileOrUntil { + "while" {} + "until" { set test !($test) } + default { + return -code error \ + "bad option \"$whileOrUntil\": must be until, or while" + } + } + break + } + + # the first invocation of the body + set code [catch { uplevel 1 $body } result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel do] \ + -errorcode $::errorCode -code error $result + } + 3 { + # FRINK: nocheck + return + } + 4 {} + default { + return -code $code $result + } + } + # the rest of the loop + set code [catch {uplevel 1 [list while $test $body]} result] + if {$code == 1} { + return -errorinfo [ErrorInfoAsCaller while do] \ + -errorcode $::errorCode -code error $result + } + return -code $code $result + + } + +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/no-op.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/no-op.tcl new file mode 100644 index 00000000..2400303f --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/no-op.tcl @@ -0,0 +1,14 @@ +# no-op.tcl -- +# +# The [no-op] command of the package "control". +# It accepts any number of arguments and does nothing. +# It returns an empty string. +# +# RCS: @(#) $Id: no-op.tcl,v 1.2 2004/01/15 06:36:12 andreas_kupries Exp $ + +namespace eval ::control { + + proc no-op args {} + +} + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/pkgIndex.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/pkgIndex.tcl new file mode 100644 index 00000000..e781098f --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/pkgIndex.tcl @@ -0,0 +1,2 @@ +if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} +package ifneeded control 0.1.4 [list source [file join $dir control.tcl]] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/tclIndex b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/tclIndex new file mode 100644 index 00000000..614d932f --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/control/tclIndex @@ -0,0 +1,18 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(::control::CommandAsCaller) [list source [file join $dir ascaller.tcl]] +set auto_index(::control::BodyAsCaller) [list source [file join $dir ascaller.tcl]] +set auto_index(::control::ErrorInfoAsCaller) [list source [file join $dir ascaller.tcl]] +set auto_index(::control::assert::EnabledAssert) [list source [file join $dir assert.tcl]] +set auto_index(::control::assert::enabled) [list source [file join $dir assert.tcl]] +set auto_index(::control::assert::callback) [list source [file join $dir assert.tcl]] +set auto_index(::control::AssertSwitch) [list source [file join $dir assert.tcl]] +set auto_index(::control::assert) [list source [file join $dir assert.tcl]] +set auto_index(::control::do) [list source [file join $dir do.tcl]] +set auto_index(::control::no-op) [list source [file join $dir no-op.tcl]] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/caller.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/caller.tcl new file mode 100644 index 00000000..e85a9f08 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/caller.tcl @@ -0,0 +1,97 @@ +## -*- tcl -*- +# ### ### ### ######### ######### ######### + +## Utility command for use as debug prefix command to un-mangle snit +## and TclOO method calls. + +# ### ### ### ######### ######### ######### +## Requisites + +package require Tcl 8.5 +package require debug + +namespace eval ::debug { + namespace export caller + namespace ensemble create +} + +# ### ### ### ######### ######### ######### +## API & Implementation + +proc ::debug::caller {args} { + # For snit (type)methods, rework the command line to be more + # legible and in line with what the user would expect. To this end + # we pull the primary command out of the arguments, be it type or + # object, massage the command to match the original (type)method + # name, then resort and expand the words to match the call before + # the snit got its claws into it. + + set a [lassign [info level -1] m] + regsub {.*Snit_} $m {} m + + if {[string match ::oo::Obj*::my $m]} { + # TclOO call. + set m [uplevel 1 self] + return [list $m {*}[Filter $a $args]] + } + if {$m eq "my"} { + # TclOO call. + set m [uplevel 1 self] + return [list $m {*}[Filter $a $args]] + } + + switch -glob -- $m { + htypemethod* { + # primary = type, a = type + set a [lassign $a primary] + set m [string map {_ { }} [string range $m 11 end]] + } + typemethod* { + # primary = type, a = type + set a [lassign $a primary] + set m [string range $m 10 end] + } + hmethod* { + # primary = self, a = type selfns self win ... + set a [lassign $a _ _ primary _] + set m [string map {_ { }} [string range $m 7 end]] + } + method* { + # primary = self, a = type selfns self win ... + set a [lassign $a _ _ primary _] + set m [string range $m 6 end] + } + destructor - + constructor { + # primary = self, a = type selfns self win ... + set a [lassign $a _ _ primary _] + } + typeconstructor { + return [list {*}$a $m] + } + default { + # Unknown + return [list $m {*}[Filter $a $args]] + } + } + return [list $primary {*}$m {*}[Filter $a $args]] +} + +proc ::debug::Filter {args droplist} { + if {[llength $droplist]} { + # Replace unwanted arguments with '*'. This is usually done + # for arguments which can be large Tcl values. These would + # screw up formatting and, to add insult to this injury, also + # repeat for each debug output in the same proc, method, etc. + foreach i [lsort -integer $droplist] { + set args [lreplace $args $i $i *] + } + } + return $args +} + +# ### ######### ########################### +## Ready for use + +package provide debug::caller 1.1 +return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/debug.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/debug.tcl new file mode 100644 index 00000000..4ce60808 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/debug.tcl @@ -0,0 +1,306 @@ +# 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/vendor/punk/project-0.1/src/bootsupport/lib/debug/heartbeat.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/heartbeat.tcl new file mode 100644 index 00000000..a00ecd94 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/heartbeat.tcl @@ -0,0 +1,68 @@ +# -*- tcl -* +# Debug -- Heartbeat. Track operation of Tcl's eventloop. +# -- Colin McCormack / originally Wub server utilities + +# # ## ### ##### ######## ############# ##################### +## Requisites + +package require Tcl 8.5 +package require debug + +namespace eval ::debug { + namespace export heartbeat + namespace ensemble create +} + +# # ## ### ##### ######## ############# ##################### +## API & Implementation + +proc ::debug::heartbeat {{delta 500}} { + variable duration $delta + variable timer + + if {$duration > 0} { + # stop a previous heartbeat before starting the next + catch { after cancel $timer } + on heartbeat + ::debug::every $duration { + debug.heartbeat {[::debug::pulse]} + } + } else { + catch { after cancel $timer } + off heartbeat + } +} + +proc ::debug::every {ms body} { + eval $body + variable timer [after $ms [info level 0]] + return +} + +proc ::debug::pulse {} { + variable duration + variable hbtimer + variable heartbeat + + set now [::tcl::clock::milliseconds] + set diff [expr {$now - $hbtimer - $duration}] + + set hbtimer $now + + return [list [incr heartbeat] $diff] +} + +# # ## ### ##### ######## ############# ##################### + +namespace eval ::debug { + variable duration 0 ; # milliseconds between heart-beats + variable heartbeat 0 ; # beat counter + variable hbtimer [::tcl::clock::milliseconds] + variable timer +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide debug::heartbeat 1.0.1 +return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/pkgIndex.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/pkgIndex.tcl new file mode 100644 index 00000000..065cc9e7 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/pkgIndex.tcl @@ -0,0 +1,5 @@ +if {![package vsatisfies [package require Tcl] 8.5]} return +package ifneeded debug 1.0.6 [list source [file join $dir debug.tcl]] +package ifneeded debug::heartbeat 1.0.1 [list source [file join $dir heartbeat.tcl]] +package ifneeded debug::timestamp 1 [list source [file join $dir timestamp.tcl]] +package ifneeded debug::caller 1.1 [list source [file join $dir caller.tcl]] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/timestamp.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/timestamp.tcl new file mode 100644 index 00000000..5fec019e --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/debug/timestamp.tcl @@ -0,0 +1,47 @@ +# -*- tcl -* +# Debug -- Timestamps. +# -- Colin McCormack / originally Wub server utilities +# +# Generate timestamps for debug messages. +# The provided commands are for use in prefixes and headers. + +# # ## ### ##### ######## ############# ##################### +## Requisites + +package require Tcl 8.5 +package require debug + +namespace eval ::debug { + namespace export timestamp + namespace ensemble create +} + +# # ## ### ##### ######## ############# ##################### +## API & Implementation + +proc ::debug::timestamp {} { + variable timestamp::delta + variable timestamp::baseline + + set now [::tcl::clock::milliseconds] + if {$delta} { + set time "${now}-[expr {$now - $delta}]mS " + } else { + set time "${now}mS " + } + set delta $now + return $time +} + +# # ## ### ##### ######## ############# ##################### + +namespace eval ::debug::timestamp { + variable delta 0 + variable baseline [::tcl::clock::milliseconds] +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide debug::timestamp 1 +return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/decode.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/decode.tcl new file mode 100644 index 00000000..341ac2a1 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/decode.tcl @@ -0,0 +1,207 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Copyright (c) 2008-2009 ActiveState Software Inc., Andreas Kupries +## 2016 Andreas Kupries +## BSD License +## +# Package to help the writing of file decoders. Provides generic +# low-level support commands. + +package require Tcl 8.5 9 + +namespace eval ::fileutil::decode { + namespace export mark go rewind at + namespace export byte short-le long-le nbytes skip + namespace export unsigned match recode getval + namespace export clear get put putloc setbuf +} + +# ### ### ### ######### ######### ######### +## + +proc ::fileutil::decode::open {fname} { + variable chan + set chan [::open $fname r] + fconfigure $chan \ + -translation binary \ + -encoding binary \ + -eofchar {} + return +} + +proc ::fileutil::decode::close {} { + variable chan + ::close $chan +} + +# ### ### ### ######### ######### ######### +## + +proc ::fileutil::decode::mark {} { + variable chan + variable mark + set mark [tell $chan] + return +} + +proc ::fileutil::decode::go {to} { + variable chan + seek $chan $to start + return +} + +proc ::fileutil::decode::rewind {} { + variable chan + variable mark + if {$mark == {}} { + return -code error \ + -errorcode {FILE DECODE NO MARK} \ + "No mark to rewind to" + } + seek $chan $mark start + set mark {} + return +} + +proc ::fileutil::decode::at {} { + variable chan + return [tell $chan] +} + +# ### ### ### ######### ######### ######### +## + +proc ::fileutil::decode::byte {} { + variable chan + variable mask 0xff + variable val [read $chan 1] + binary scan $val c val + return +} + +proc ::fileutil::decode::short-le {} { + variable chan + variable mask 0xffff + variable val [read $chan 2] + binary scan $val s val + return +} + +proc ::fileutil::decode::long-le {} { + variable chan + variable mask 0xffffffff + variable val [read $chan 4] + binary scan $val i val + return +} + +proc ::fileutil::decode::nbytes {n} { + variable chan + variable mask {} + variable val [read $chan $n] + return +} + +proc ::fileutil::decode::skip {n} { + variable chan + #read $chan $n + seek $chan $n current + return +} + +# ### ### ### ######### ######### ######### +## + +proc ::fileutil::decode::unsigned {} { + variable val + if {$val >= 0} return + variable mask + if {$mask eq {}} { + return -code error \ + -errorcode {FILE DECODE ILLEGAL UNSIGNED} \ + "Unsigned not possible here" + } + set val [format %u [expr {$val & $mask}]] + return +} + +proc ::fileutil::decode::match {eval} { + variable val + + #puts "Match: Expected $eval, Got: [format 0x%08x $val]" + + if {$val == $eval} {return 1} + rewind + return 0 +} + +proc ::fileutil::decode::recode {cmdpfx} { + variable val + lappend cmdpfx $val + set val [uplevel 1 $cmdpfx] + return +} + +proc ::fileutil::decode::getval {} { + variable val + return $val +} + +# ### ### ### ######### ######### ######### +## + +proc ::fileutil::decode::clear {} { + variable buf {} + return +} + +proc ::fileutil::decode::get {} { + variable buf + return $buf +} + +proc ::fileutil::decode::setbuf {list} { + variable buf $list + return +} + +proc ::fileutil::decode::put {name} { + variable buf + variable val + lappend buf $name $val + return +} + +proc ::fileutil::decode::putloc {name} { + variable buf + variable chan + lappend buf $name [tell $chan] + return +} + +# ### ### ### ######### ######### ######### +## + +namespace eval ::fileutil::decode { + # Stream to read from + variable chan {} + + # Last value read from the stream, or modified through decoder + # operations. + variable val {} + + # Remembered location in the stream + variable mark {} + + # Buffer for accumulating structured results + variable buf {} + + # Mask for trimming a value to unsigned. + # Size-dependent + variable mask {} +} + +# ### ### ### ######### ######### ######### +## Ready +package provide fileutil::decode 0.2.2 +return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/fileutil-1.16.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/fileutil.tcl similarity index 85% rename from src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/fileutil-1.16.1.tm rename to src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/fileutil.tcl index 6d5c737e..bb80f45b 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/fileutil-1.16.1.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/fileutil.tcl @@ -9,9 +9,9 @@ # 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 require Tcl 8.5 9 package require cmdline -package provide fileutil 1.16.1 +package provide fileutil 1.16.2 namespace eval ::fileutil { namespace export \ @@ -196,237 +196,55 @@ proc ::fileutil::FADD {filename} { return } -# The next three helper commands for fileutil::find depend strongly on -# the version of Tcl, and partially on the platform. - -# 1. The -directory and -types switches were added to glob in Tcl -# 8.3. This means that we have to emulate them for Tcl 8.2. -# -# 2. In Tcl 8.3 using -types f will return only true files, but not -# links to files. This changed in 8.4+ where links to files are -# returned as well. So for 8.3 we have to handle the links -# separately (-types l) and also filter on our own. -# Note that Windows file links are hard links which are reported by -# -types f, but not -types l, so we can optimize that for the two -# platforms. -# -# Note further that we have to handle broken links on our own. They -# are not returned by glob yet we want them in the output. -# -# 3. In Tcl 8.3 we also have a crashing bug in glob (SIGABRT, "stat on -# a known file") when trying to perform 'glob -types {hidden f}' on -# a directory without e'x'ecute permissions. We code around by -# testing if we can cd into the directory (stat might return enough -# information too (mode), but possibly also not portable). -# -# For Tcl 8.2 and 8.4+ glob simply delivers an empty result -# (-nocomplain), without crashing. For them this command is defined -# so that the bytecode compiler removes it from the bytecode. -# -# This bug made the ACCESS helper necessary. -# We code around the problem by testing if we can cd into the -# directory (stat might return enough information too (mode), but -# possibly also not portable). - -if {[package vsatisfies [package present Tcl] 8.5]} { - # Tcl 8.5+. - # We have to check readability of "current" on our own, glob - # changed to error out instead of returning nothing. - - proc ::fileutil::ACCESS {args} {} - - proc ::fileutil::GLOBF {current} { - if {![file readable $current] || - [BadLink $current]} { - return {} - } - - set res [lsort -unique [concat \ - [glob -nocomplain -directory $current -types f -- *] \ - [glob -nocomplain -directory $current -types {hidden f} -- *]]] - - # Look for broken links (They are reported as neither file nor directory). - foreach l [lsort -unique [concat \ - [glob -nocomplain -directory $current -types l -- *] \ - [glob -nocomplain -directory $current -types {hidden l} -- *]]] { - if {[file isfile $l]} continue - if {[file isdirectory $l]} continue - lappend res $l - } - return [lsort -unique $res] - } - - proc ::fileutil::GLOBD {current} { - if {![file readable $current] || - [BadLink $current]} { - return {} - } - - lsort -unique [concat \ - [glob -nocomplain -directory $current -types d -- *] \ - [glob -nocomplain -directory $current -types {hidden d} -- *]] - } - - proc ::fileutil::BadLink {current} { - if {[file type $current] ne "link"} { return no } +# Tcl 8.5+. +# We have to check readability of "current" on our own, glob +# changed to error out instead of returning nothing. - set dst [file join [file dirname $current] [file readlink $current]] - - if {![file exists $dst] || - ![file readable $dst]} { - return yes - } +proc ::fileutil::ACCESS {args} {} - return no +proc ::fileutil::GLOBF {current} { + if {![file readable $current] || + [BadLink $current]} { + return {} } -} elseif {[package vsatisfies [package present Tcl] 8.4]} { - # Tcl 8.4+. - # (Ad 1) We have -directory, and -types, - # (Ad 2) Links are returned for -types f/d if they refer to files/dirs. - # (Ad 3) No bug to code around - - proc ::fileutil::ACCESS {args} {} - - proc ::fileutil::GLOBF {current} { - set res [lsort -unique [concat \ - [glob -nocomplain -directory $current -types f -- *] \ - [glob -nocomplain -directory $current -types {hidden f} -- *]]] - # Look for broken links (They are reported as neither file nor directory). - foreach l [lsort -unique [concat \ - [glob -nocomplain -directory $current -types l -- *] \ - [glob -nocomplain -directory $current -types {hidden l} -- *]]] { - if {[file isfile $l]} continue - if {[file isdirectory $l]} continue - lappend res $l - } - return [lsort -unique $res] - } + set res [lsort -unique [concat \ + [glob -nocomplain -directory $current -types f -- *] \ + [glob -nocomplain -directory $current -types {hidden f} -- *]]] - proc ::fileutil::GLOBD {current} { - lsort -unique [concat \ - [glob -nocomplain -directory $current -types d -- *] \ - [glob -nocomplain -directory $current -types {hidden d} -- *]] + # Look for broken links (They are reported as neither file nor directory). + foreach l [lsort -unique [concat \ + [glob -nocomplain -directory $current -types l -- *] \ + [glob -nocomplain -directory $current -types {hidden l} -- *]]] { + if {[file isfile $l]} continue + if {[file isdirectory $l]} continue + lappend res $l } + return [lsort -unique $res] +} -} elseif {[package vsatisfies [package present Tcl] 8.3]} { - # 8.3. - # (Ad 1) We have -directory, and -types, - # (Ad 2) Links are NOT returned for -types f/d, collect separately. - # No symbolic file links on Windows. - # (Ad 3) Bug to code around. - - proc ::fileutil::ACCESS {current} { - if {[catch { - set h [pwd] ; cd $current ; cd $h - }]} {return -code continue} - return +proc ::fileutil::GLOBD {current} { + if {![file readable $current] || + [BadLink $current]} { + return {} } - if {[string equal $::tcl_platform(platform) windows]} { - proc ::fileutil::GLOBF {current} { - concat \ - [glob -nocomplain -directory $current -types f -- *] \ - [glob -nocomplain -directory $current -types {hidden f} -- *]] - } - } else { - proc ::fileutil::GLOBF {current} { - set l [concat \ - [glob -nocomplain -directory $current -types f -- *] \ - [glob -nocomplain -directory $current -types {hidden f} -- *]] - - foreach x [concat \ - [glob -nocomplain -directory $current -types l -- *] \ - [glob -nocomplain -directory $current -types {hidden l} -- *]] { - if {[file isdirectory $x]} continue - # We have now accepted files, links to files, and broken links. - lappend l $x - } - - return $l - } - } + lsort -unique [concat \ + [glob -nocomplain -directory $current -types d -- *] \ + [glob -nocomplain -directory $current -types {hidden d} -- *]] +} - proc ::fileutil::GLOBD {current} { - set l [concat \ - [glob -nocomplain -directory $current -types d -- *] \ - [glob -nocomplain -directory $current -types {hidden d} -- *]] +proc ::fileutil::BadLink {current} { + if {[file type $current] ne "link"} { return no } - foreach x [concat \ - [glob -nocomplain -directory $current -types l -- *] \ - [glob -nocomplain -directory $current -types {hidden l} -- *]] { - if {![file isdirectory $x]} continue - lappend l $x - } + set dst [file join [file dirname $current] [file readlink $current]] - return $l + if {![file exists $dst] || + ![file readable $dst]} { + return yes } -} else { - # 8.2. - # (Ad 1,2,3) We do not have -directory, nor -types. Full emulation required. - - proc ::fileutil::ACCESS {args} {} - - if {[string equal $::tcl_platform(platform) windows]} { - # Hidden files cannot be handled by Tcl 8.2 in glob. We have - # to punt. - - proc ::fileutil::GLOBF {current} { - set current \\[join [split $current {}] \\] - set res {} - foreach x [glob -nocomplain -- [file join $current *]] { - if {[file isdirectory $x]} continue - if {[catch {file type $x}]} continue - # We have now accepted files, links to files, and - # broken links. We may also have accepted a directory - # as well, if the current path was inaccessible. This - # however will cause 'file type' to throw an error, - # hence the second check. - lappend res $x - } - return $res - } - - proc ::fileutil::GLOBD {current} { - set current \\[join [split $current {}] \\] - set res {} - foreach x [glob -nocomplain -- [file join $current *]] { - if {![file isdirectory $x]} continue - lappend res $x - } - return $res - } - } else { - # Hidden files on Unix are dot-files. We emulate the switch - # '-types hidden' by using an explicit pattern. - - proc ::fileutil::GLOBF {current} { - set current \\[join [split $current {}] \\] - set res {} - foreach x [glob -nocomplain -- [file join $current *] [file join $current .*]] { - if {[file isdirectory $x]} continue - if {[catch {file type $x}]} continue - # We have now accepted files, links to files, and - # broken links. We may also have accepted a directory - # as well, if the current path was inaccessible. This - # however will cause 'file type' to throw an error, - # hence the second check. - - lappend res $x - } - return $res - } - proc ::fileutil::GLOBD {current} { - set current \\[join [split $current {}] \\] - set res {} - foreach x [glob -nocomplain -- $current/* [file join $current .*]] { - if {![file isdirectory $x]} continue - lappend res $x - } - return $res - } - } + return no } # ::fileutil::findByPattern -- @@ -1459,56 +1277,50 @@ proc ::fileutil::foreachLine {var filename cmd} { # Errors: # Both of "-r" and "-t" cannot be specified. -if {[package vsatisfies [package provide Tcl] 8.3]} { - namespace eval ::fileutil { - namespace export touch - } - - proc ::fileutil::touch {args} { - # Don't bother catching errors, just let them propagate up +proc ::fileutil::touch {args} { + # Don't bother catching errors, just let them propagate up - set options { - {a "set the atime only"} - {m "set the mtime only"} - {c "do not create non-existant files"} - {r.arg "" "use time from ref_file"} - {t.arg -1 "use specified time"} - } - set usage ": [lindex [info level 0] 0]\ + set options { + {a "set the atime only"} + {m "set the mtime only"} + {c "do not create non-existant files"} + {r.arg "" "use time from ref_file"} + {t.arg -1 "use specified time"} + } + set usage ": [lindex [info level 0] 0]\ \[options] filename ...\noptions:" - array set params [::cmdline::getoptions args $options $usage] - - # process -a and -m options - set set_atime [set set_mtime "true"] - if { $params(a) && ! $params(m)} {set set_mtime "false"} - if {! $params(a) && $params(m)} {set set_atime "false"} - - # process -r and -t - set has_t [expr {$params(t) != -1}] - set has_r [expr {[string length $params(r)] > 0}] - if {$has_t && $has_r} { - return -code error "Cannot specify both -r and -t" - } elseif {$has_t} { - set atime [set mtime $params(t)] - } elseif {$has_r} { - file stat $params(r) stat - set atime $stat(atime) - set mtime $stat(mtime) - } else { - set atime [set mtime [clock seconds]] - } + array set params [::cmdline::getoptions args $options $usage] - # do it - foreach filename $args { - if {! [file exists $filename]} { - if {$params(c)} {continue} - close [open $filename w] - } - if {$set_atime} {file atime $filename $atime} - if {$set_mtime} {file mtime $filename $mtime} + # process -a and -m options + set set_atime [set set_mtime "true"] + if { $params(a) && ! $params(m)} {set set_mtime "false"} + if {! $params(a) && $params(m)} {set set_atime "false"} + + # process -r and -t + set has_t [expr {$params(t) != -1}] + set has_r [expr {[string length $params(r)] > 0}] + if {$has_t && $has_r} { + return -code error "Cannot specify both -r and -t" + } elseif {$has_t} { + set atime [set mtime $params(t)] + } elseif {$has_r} { + file stat $params(r) stat + set atime $stat(atime) + set mtime $stat(mtime) + } else { + set atime [set mtime [clock seconds]] + } + + # do it + foreach filename $args { + if {! [file exists $filename]} { + if {$params(c)} {continue} + close [open $filename w] } - return + if {$set_atime} {file atime $filename $atime} + if {$set_mtime} {file mtime $filename $mtime} } + return } # ::fileutil::fileType -- @@ -1921,7 +1733,7 @@ proc ::fileutil::MakeTempDir {config} { if {[catch { file mkdir $path if {$::tcl_platform(platform) eq "unix"} { - file attributes $path -permissions 0700 + file attributes $path -permissions 0o700 } }]} continue diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/multi.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/multi.tcl new file mode 100644 index 00000000..757b83ed --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/multi.tcl @@ -0,0 +1,28 @@ +# ### ### ### ######### ######### ######### +## +# (c) 2007 Andreas Kupries. + +# Multi file operations. Singleton based on the multiop processor. + +# ### ### ### ######### ######### ######### +## Requisites + +package require fileutil::multi::op + +# ### ### ### ######### ######### ######### +## API & Implementation + +namespace eval ::fileutil {} + +# Create the multiop processor object and make its do method the main +# command of this package. +::fileutil::multi::op ::fileutil::multi::obj + +proc ::fileutil::multi {args} { + return [uplevel 1 [linsert $args 0 ::fileutil::multi::obj do]] +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide fileutil::multi 0.2 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/multiop.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/multiop.tcl new file mode 100644 index 00000000..72a9e5b0 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/multiop.tcl @@ -0,0 +1,645 @@ +# ### ### ### ######### ######### ######### +## +# (c) 2007-2008 Andreas Kupries. + +# DSL allowing the easy specification of multi-file copy and/or move +# and/or deletion operations. Alternate names would be scatter/gather +# processor, or maybe even assembler. + +# Examples: +# (1) copy +# into [installdir_of tls] +# from c:/TDK/PrivateOpenSSL/bin +# the *.dll +# +# (2) move +# from /sources +# into /scratch +# the * +# but not *.html +# (Alternatively: except for *.html) +# +# (3) into /scratch +# from /sources +# move +# as pkgIndex.tcl +# the index +# +# (4) in /scratch +# remove +# the *.txt + +# The language is derived from the parts of TclApp's option language +# dealing with files and their locations, yet not identical. In parts +# simplified, in parts more capable, keyword names were changed +# throughout. + +# Language commands + +# From the examples +# +# into DIR : Specify destination directory. +# in DIR : See 'into'. +# from DIR : Specify source directory. +# the PATTERN (...) : Specify files to operate on. +# but not PATTERN : Specify exceptions to 'the'. +# but exclude PATTERN : Specify exceptions to 'the'. +# except for PATTERN : See 'but not'. +# as NAME : New name for file. +# move : Move files. +# copy : Copy files. +# remove : Delete files. +# +# Furthermore +# +# reset : Force to defaults. +# cd DIR : Change destination to subdirectory. +# up : Change destination to parent directory. +# ( : Save a copy of the current state. +# ) : Restore last saved state and make it current. + +# The main active element is the command 'the'. In other words, this +# command not only specifies the files to operate on, but also +# executes the operation as defined in the current state. All other +# commands modify the state to set the operation up, and nothing +# else. To allow for a more natural syntax the active command also +# looks ahead for the commands 'as', 'but', and 'except', and executes +# them, like qualifiers, so that they take effect as if they had been +# written before. The command 'but' and 'except use identical +# constructions to handle their qualifiers, i.e. 'not' and 'for'. + +# Note that the fact that most commands just modify the state allows +# us to use more off forms as specifications instead of just natural +# language sentences For example the example 2 can re-arranged into: +# +# (5) from /sources +# into /scratch +# but not *.html +# move +# the * +# +# and the result is still a valid specification. + +# Further note that the information collected by 'but', 'except', and +# 'as' is automatically reset after the associated 'the' was +# executed. However no other state is reset in that manner, allowing +# the user to avoid repetitions of unchanging information. Lets us for +# example merge the examples 2 and 3. The trivial merge is: + +# (6) move +# into /scratch +# from /sources +# the * +# but not *.html not index +# move +# into /scratch +# from /sources +# the index +# as pkgIndex.tcl +# +# With less repetitions +# +# (7) move +# into /scratch +# from /sources +# the * +# but not *.html not index +# the index +# as pkgIndex.tcl + +# I have not yet managed to find a suitable syntax to specify when to +# add a new extension to the moved/copied files, or have to strip all +# extensions, a specific extension, or even replace extensions. + +# Other possibilities to muse about: Load the patterns for 'not'/'for' +# from a file ... Actually, load the whole exceptions from a file, +# with its contents a proper interpretable word list. Which makes it +# general processing of include files. + +# ### ### ### ######### ######### ######### +## Requisites + +# This processor uses the 'wip' word list interpreter as its +# foundation. + +package require fileutil ; # File testing +package require snit ; # OO support +package require struct::stack ; # Context stack +package require wip ; # DSL execution core + +# ### ### ### ######### ######### ######### +## API & Implementation + +snit::type ::fileutil::multi::op { + # ### ### ### ######### ######### ######### + ## API + + constructor {args} {} ; # create processor + + # ### ### ### ######### ######### ######### + ## API - Implementation. + + constructor {args} { + install stack using struct::stack ${selfns}::stack + $self wip_setup + + # Mapping dsl commands to methods. + defdva \ + reset Reset ( Push ) Pop \ + into Into in Into from From \ + cd ChDir up ChUp as As \ + move Move copy Copy remove Remove \ + but But not Exclude the The \ + except Except for Exclude exclude Exclude \ + to Into -> Save the-set TheSet \ + recursive Recursive recursively Recursive \ + for-win ForWindows for-unix ForUnix \ + for-windows ForWindows expand Expand \ + invoke Invoke strict Strict !strict NotStrict \ + files Files links Links all Everything \ + dirs Directories directories Directories \ + state? QueryState from? QueryFrom into? QueryInto \ + excluded? QueryExcluded as? QueryAs type? QueryType \ + recursive? QueryRecursive operation? QueryOperation \ + strict? QueryStrict !recursive NotRecursive + + $self Reset + runl $args + return + } + + destructor { + $mywip destroy + return + } + + method do {args} { + return [runl $args] + } + + # ### ### ### ######### ######### ######### + ## DSL Implementation + wip::dsl + + # General reset of processor state + method Reset {} { + $stack clear + set base "" + set alias "" + set op "" + set recursive 0 + set src "" + set excl "" + set types {} + set strict 0 + return + } + + # Stack manipulation + method Push {} { + $stack push [list $base $alias $op $opcmd $recursive $src $excl $types $strict] + return + } + + method Pop {} { + if {![$stack size]} { + return -code error {Stack underflow} + } + foreach {base alias op opcmd recursive src excl types strict} [$stack pop] break + return + } + + # Destination directory + method Into {dir} { + if {$dir eq ""} {set dir [pwd]} + if {$strict && ![fileutil::test $dir edr msg {Destination directory}]} { + return -code error $msg + } + set base $dir + return + } + + method ChDir {dir} { $self Into [file join $base $dir] ; return } + method ChUp {} { $self Into [file dirname $base] ; return } + + # Detail + method As {fname} { + set alias [ForceRelative $fname] + return + } + + # Operations + method Move {} { set op move ; return } + method Copy {} { set op copy ; return } + method Remove {} { set op remove ; return } + method Expand {} { set op expand ; return } + + method Invoke {cmdprefix} { + set op invoke + set opcmd $cmdprefix + return + } + + # Operation qualifier + method Recursive {} { set recursive 1 ; return } + method NotRecursive {} { set recursive 0 ; return } + + # Source directory + method From {dir} { + if {$dir eq ""} {set dir [pwd]} + if {![fileutil::test $dir edr msg {Source directory}]} { + return -code error $msg + } + set src $dir + return + } + + # Exceptions + method But {} { run_next_while {not exclude} ; return } + method Except {} { run_next_while {for} ; return } + + method Exclude {pattern} { + lappend excl $pattern + return + } + + # Define the files to operate on, and perform the operation. + method The {pattern} { + run_next_while {as but except exclude from into in to files dirs directories links all} + + switch -exact -- $op { + invoke {Invoke [Resolve [Remember [Exclude [Expand $src $pattern]]]]} + move {Move [Resolve [Remember [Exclude [Expand $src $pattern]]]]} + copy {Copy [Resolve [Remember [Exclude [Expand $src $pattern]]]]} + remove {Remove [Remember [Exclude [Expand $base $pattern]]] } + expand { Remember [Exclude [Expand $base $pattern]] } + } + + # Reset the per-pattern flags of the resolution context back + # to their defaults, for the next pattern. + + set alias {} + set excl {} + set recursive 0 + return + } + + # Like 'The' above, except that the fileset is taken from the + # specified variable. Semi-complementary to 'Save' below. + # Exclusion data and recursion info do not apply for this, this is + # already implicitly covered by the set, when it was generated. + + method TheSet {varname} { + # See 'Save' for the levels we jump here. + upvar 5 $varname var + + run_next_while {as from into in to} + + switch -exact -- $op { + invoke {Invoke [Resolve $var]} + move {Move [Resolve $var]} + copy {Copy [Resolve $var]} + remove {Remove $var } + expand { + return -code error "Expansion does not make sense\ + when we already have a set of files." + } + } + + # Reset the per-pattern flags of the resolution context back + # to their defaults, for the next pattern. + + set alias {} + return + } + + # Save the last expansion result to a variable for use by future commands. + + method Save {varname} { + # Levels to jump. Brittle. + # 5: Caller + # 4: object do ... + # 3: runl + # 2: wip::runl + # 1: run_next + # 0: Here + upvar 5 $varname v + set v $lastexpansion + return + } + + # Platform conditionals ... + + method ForUnix {} { + global tcl_platform + if {$tcl_platform(platform) eq "unix"} return + # Kill the remaining code. This effectively aborts processing. + replacel {} + return + } + + method ForWindows {} { + global tcl_platform + if {$tcl_platform(platform) eq "windows"} return + # Kill the remaining code. This effectively aborts processing. + replacel {} + return + } + + # Strictness + + method Strict {} { + set strict 1 + return + } + + method NotStrict {} { + set strict 0 + return + } + + # Type qualifiers + + method Files {} { + set types files + return + } + + method Links {} { + set types links + return + } + + method Directories {} { + set types dirs + return + } + + method Everything {} { + set types {} + return + } + + # State interogation + + method QueryState {} { + return [list \ + from $src \ + into $base \ + as $alias \ + op $op \ + excluded $excl \ + recursive $recursive \ + type $types \ + strict $strict \ + ] + } + method QueryExcluded {} { + return $excl + } + method QueryFrom {} { + return $src + } + method QueryInto {} { + return $base + } + method QueryAs {} { + return $alias + } + method QueryOperation {} { + return $op + } + method QueryRecursive {} { + return $recursive + } + method QueryType {} { + return $types + } + method QueryStrict {} { + return $strict + } + + # ### ### ### ######### ######### ######### + ## DSL State + + component stack ; # State stack - ( ) + variable base "" ; # Destination dir - into, in, cd, up + variable alias "" ; # Detail - as + variable op "" ; # Operation - move, copy, remove, expand, invoke + variable opcmd "" ; # Command prefix for invoke. + variable recursive 0 ; # Op. qualifier: recursive expansion? + variable src "" ; # Source dir - from + variable excl "" ; # Excluded files - but not|exclude, except for + # incl ; # Included files - the (immediate use) + variable types {} ; # Limit glob/find to specific types (f, l, d). + variable strict 0 ; # Strictness of into/Expand + + variable lastexpansion "" ; # Area for last expansion result, for 'Save' to take from. + + # ### ### ### ######### ######### ######### + ## Internal -- Path manipulation helpers. + + proc ForceRelative {path} { + set pathtype [file pathtype $path] + switch -exact -- $pathtype { + relative { + return $path + } + absolute { + # Chop off the first element in the path, which is the + # root, either '/' or 'x:/'. If this was the only + # element assume an empty path. + + set path [lrange [file split $path] 1 end] + if {![llength $path]} {return {}} + return [eval [linsert $path 0 file join]] + } + volumerelative { + return -code error {Unable to handle volumerelative path, yet} + } + } + + return -code error \ + "file pathtype returned unknown type \"$pathtype\"" + } + + proc ForceAbsolute {path} { + return [file join [pwd] $path] + } + + # ### ### ### ######### ######### ######### + ## Internal - Operation execution helpers + + proc Invoke {files} { + upvar 1 base base src src opcmd opcmd + uplevel #0 [linsert $opcmd end $src $base $files] + return + } + + proc Move {files} { + upvar 1 base base src src + + foreach {s d} $files { + set s [file join $src $s] + set d [file join $base $d] + + file mkdir [file dirname $d] + file rename -force $s $d + } + return + } + + proc Copy {files} { + upvar 1 base base src src + + foreach {s d} $files { + set s [file join $src $s] + set d [file join $base $d] + + file mkdir [file dirname $d] + if { + [file isdirectory $s] && + [file exists $d] && + [file isdirectory $d] + } { + # Special case: source and destination are + # directories, and the latter exists. This puts the + # source under the destination, and may even prevent + # copying at all. The semantics of the operation is + # that the source is the destination. We avoid the + # trouble by copying the contents of the source, + # instead of the directory itself. + foreach path [glob -directory $s *] { + file copy -force $path $d + } + } else { + file copy -force $s $d + } + } + return + } + + proc Remove {files} { + upvar 1 base base + + foreach f $files { + file delete -force [file join $base $f] + } + return + } + + # ### ### ### ######### ######### ######### + ## Internal -- Resolution helper commands + + typevariable tmap -array { + files {f TFile} + links {l TLink} + dirs {d TDir} + {} {{} {}} + } + + proc Expand {dir pattern} { + upvar 1 recursive recursive strict strict types types tmap tmap + # FUTURE: struct::list filter ... + + set files {} + if {$recursive} { + # Recursion through the entire directory hierarchy, save + # all matching paths. + + set filter [lindex $tmap($types) 1] + if {$filter ne ""} { + set filter [myproc $filter] + } + + foreach f [fileutil::find $dir $filter] { + if {![string match $pattern [file tail $f]]} continue + lappend files [fileutil::stripPath $dir $f] + } + } else { + # No recursion, just scan the whole directory for matching paths. + # check for specific types integrated. + + set filter [lindex $tmap($types) 0] + if {$filter ne ""} { + foreach f [glob -nocomplain -directory $dir -types $filter -- $pattern] { + lappend files [fileutil::stripPath $dir $f] + } + } else { + foreach f [glob -nocomplain -directory $dir -- $pattern] { + lappend files [fileutil::stripPath $dir $f] + } + } + } + + if {[llength $files]} {return $files} + if {!$strict} {return {}} + + return -code error \ + "No files matching pattern \"$pattern\" in directory \"$dir\"" + } + + proc TFile {f} {file isfile $f} + proc TDir {f} {file isdirectory $f} + proc TLink {f} {expr {[file type $f] eq "link"}} + + proc Exclude {files} { + upvar 1 excl excl + + # FUTURE: struct::list filter ... + set res {} + foreach f $files { + if {[IsExcluded $f $excl]} continue + lappend res $f + } + return $res + } + + proc IsExcluded {f patterns} { + foreach p $patterns { + if {[string match $p $f]} {return 1} + } + return 0 + } + + proc Resolve {files} { + upvar 1 alias alias + set res {} + foreach f $files { + + # Remember alias for processing and auto-invalidate to + # prevent contamination of the next file. + + set thealias $alias + set alias "" + + if {$thealias eq ""} { + set d $f + } else { + set d [file dirname $f] + if {$d eq "."} { + set d $thealias + } else { + set d [file join $d $thealias] + } + } + + lappend res $f $d + } + return $res + } + + proc Remember {files} { + upvar 1 lastexpansion lastexpansion + set lastexpansion $files + return $files + } + + ## + # ### ### ### ######### ######### ######### +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide fileutil::multi::op 0.5.4 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/fileutil/paths-1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/paths.tcl similarity index 95% rename from src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/fileutil/paths-1.tm rename to src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/paths.tcl index e387acf7..107b239e 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/fileutil/paths-1.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/paths.tcl @@ -12,7 +12,7 @@ # ### ### ### ######### ######### ######### ## Requisites -package require Tcl 8.4 +package require Tcl 8.5 9 package require snit # ### ### ### ######### ######### ######### @@ -70,5 +70,5 @@ snit::type ::fileutil::paths { # ### ### ### ######### ######### ######### ## Ready -package provide fileutil::paths 1 +package provide fileutil::paths 1.1 return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/pkgIndex.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/pkgIndex.tcl new file mode 100644 index 00000000..29bb2fec --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/pkgIndex.tcl @@ -0,0 +1,7 @@ +if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} +package ifneeded fileutil 1.16.2 [list source [file join $dir fileutil.tcl]] +package ifneeded fileutil::traverse 0.7 [list source [file join $dir traverse.tcl]] +package ifneeded fileutil::multi 0.2 [list source [file join $dir multi.tcl]] +package ifneeded fileutil::multi::op 0.5.4 [list source [file join $dir multiop.tcl]] +package ifneeded fileutil::decode 0.2.2 [list source [file join $dir decode.tcl]] +package ifneeded fileutil::paths 1.1 [list source [file join $dir paths.tcl]] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/fileutil/traverse-0.6.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/traverse.tcl similarity index 63% rename from src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/fileutil/traverse-0.6.tm rename to src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/traverse.tcl index 2f36d109..6d8fd8eb 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/fileutil/traverse-0.6.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/fileutil/traverse.tcl @@ -7,10 +7,10 @@ # 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.3 +package require Tcl 8.5 9 # OO core -if {[package vsatisfies [package present Tcl] 8.5]} { +if {[package vsatisfies [package present Tcl] 8.5 9]} { # Use new Tcl 8.5a6+ features to specify the allowed packages. # We can use anything above 1.3. This means v2 as well. package require snit 1.3- @@ -336,169 +336,58 @@ snit::type ::fileutil::traverse { # ### ### ### ######### ######### ######### ## -# The next three helper commands for the traverser depend strongly on -# the version of Tcl, and partially on the platform. +# Tcl 8.5+. +# We have to check readability of "current" on our own, glob +# changed to error out instead of returning nothing. -# 1. In Tcl 8.3 using -types f will return only true files, but not -# links to files. This changed in 8.4+ where links to files are -# returned as well. So for 8.3 we have to handle the links -# separately (-types l) and also filter on our own. -# Note that Windows file links are hard links which are reported by -# -types f, but not -types l, so we can optimize that for the two -# platforms. -# -# 2. In Tcl 8.3 we also have a crashing bug in glob (SIGABRT, "stat on -# a known file") when trying to perform 'glob -types {hidden f}' on -# a directory without e'x'ecute permissions. We code around by -# testing if we can cd into the directory (stat might return enough -# information too (mode), but possibly also not portable). -# -# For Tcl 8.2 and 8.4+ glob simply delivers an empty result -# (-nocomplain), without crashing. For them this command is defined -# so that the bytecode compiler removes it from the bytecode. -# -# This bug made the ACCESS helper necessary. -# We code around the problem by testing if we can cd into the -# directory (stat might return enough information too (mode), but -# possibly also not portable). - -if {[package vsatisfies [package present Tcl] 8.5]} { - # Tcl 8.5+. - # We have to check readability of "current" on our own, glob - # changed to error out instead of returning nothing. - - proc ::fileutil::traverse::ACCESS {args} {return 1} - - proc ::fileutil::traverse::GLOBF {current} { - if {![file readable $current] || - [BadLink $current]} { - return {} - } - - set res [lsort -unique [concat \ - [glob -nocomplain -directory $current -types f -- *] \ - [glob -nocomplain -directory $current -types {hidden f} -- *]]] - - # Look for broken links (They are reported as neither file nor directory). - foreach l [lsort -unique [concat \ - [glob -nocomplain -directory $current -types l -- *] \ - [glob -nocomplain -directory $current -types {hidden l} -- *]]] { - if {[file isfile $l]} continue - if {[file isdirectory $l]} continue - lappend res $l - } - return [lsort -unique $res] - } +proc ::fileutil::traverse::ACCESS {args} {return 1} - proc ::fileutil::traverse::GLOBD {current} { - if {![file readable $current] || - [BadLink $current]} { - return {} - } - - lsort -unique [concat \ - [glob -nocomplain -directory $current -types d -- *] \ - [glob -nocomplain -directory $current -types {hidden d} -- *]] +proc ::fileutil::traverse::GLOBF {current} { + if {![file readable $current] || + [BadLink $current]} { + return {} } - proc ::fileutil::traverse::BadLink {current} { - if {[file type $current] ne "link"} { return no } - - set dst [file join [file dirname $current] [file readlink $current]] - - if {![file exists $dst] || - ![file readable $dst]} { - return yes - } - - return no + set res [lsort -unique [concat \ + [glob -nocomplain -directory $current -types f -- *] \ + [glob -nocomplain -directory $current -types {hidden f} -- *]]] + + # Look for broken links (They are reported as neither file nor directory). + foreach l [lsort -unique [concat \ + [glob -nocomplain -directory $current -types l -- *] \ + [glob -nocomplain -directory $current -types {hidden l} -- *]]] { + if {[file isfile $l]} continue + if {[file isdirectory $l]} continue + lappend res $l } + return [lsort -unique $res] +} -} elseif {[package vsatisfies [package present Tcl] 8.4]} { - # Tcl 8.4+. - # (Ad 1) We have -directory, and -types, - # (Ad 2) Links are returned for -types f/d if they refer to files/dirs. - # (Ad 3) No bug to code around - - proc ::fileutil::traverse::ACCESS {args} {return 1} - - proc ::fileutil::traverse::GLOBF {current} { - set res [concat \ - [glob -nocomplain -directory $current -types f -- *] \ - [glob -nocomplain -directory $current -types {hidden f} -- *]] - - # Look for broken links (They are reported as neither file nor directory). - foreach l [concat \ - [glob -nocomplain -directory $current -types l -- *] \ - [glob -nocomplain -directory $current -types {hidden l} -- *] ] { - if {[file isfile $l]} continue - if {[file isdirectory $l]} continue - lappend res $l - } - return $res +proc ::fileutil::traverse::GLOBD {current} { + if {![file readable $current] || + [BadLink $current]} { + return {} } - proc ::fileutil::traverse::GLOBD {current} { - concat \ - [glob -nocomplain -directory $current -types d -- *] \ - [glob -nocomplain -directory $current -types {hidden d} -- *] - } + lsort -unique [concat \ + [glob -nocomplain -directory $current -types d -- *] \ + [glob -nocomplain -directory $current -types {hidden d} -- *]] +} -} else { - # 8.3. - # (Ad 1) We have -directory, and -types, - # (Ad 2) Links are NOT returned for -types f/d, collect separately. - # No symbolic file links on Windows. - # (Ad 3) Bug to code around. - - proc ::fileutil::traverse::ACCESS {current} { - if {[catch { - set h [pwd] ; cd $current ; cd $h - }]} {return 0} - return 1 - } +proc ::fileutil::traverse::BadLink {current} { + if {[file type $current] ne "link"} { return no } - if {[string equal $::tcl_platform(platform) windows]} { - proc ::fileutil::traverse::GLOBF {current} { - concat \ - [glob -nocomplain -directory $current -types f -- *] \ - [glob -nocomplain -directory $current -types {hidden f} -- *]] - } - } else { - proc ::fileutil::traverse::GLOBF {current} { - set l [concat \ - [glob -nocomplain -directory $current -types f -- *] \ - [glob -nocomplain -directory $current -types {hidden f} -- *]] - - foreach x [concat \ - [glob -nocomplain -directory $current -types l -- *] \ - [glob -nocomplain -directory $current -types {hidden l} -- *]] { - if {[file isdirectory $x]} continue - # We have now accepted files, links to files, and broken links. - lappend l $x - } + set dst [file join [file dirname $current] [file readlink $current]] - return $l - } + if {![file exists $dst] || + ![file readable $dst]} { + return yes } - proc ::fileutil::traverse::GLOBD {current} { - set l [concat \ - [glob -nocomplain -directory $current -types d -- *] \ - [glob -nocomplain -directory $current -types {hidden d} -- *]] - - foreach x [concat \ - [glob -nocomplain -directory $current -types l -- *] \ - [glob -nocomplain -directory $current -types {hidden l} -- *]] { - if {![file isdirectory $x]} continue - lappend l $x - } - - return $l - } + return no } # ### ### ### ######### ######### ######### ## Ready -package provide fileutil::traverse 0.6 +package provide fileutil::traverse 0.7 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/main1.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/main1.tcl new file mode 100644 index 00000000..9cbe4805 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/main1.tcl @@ -0,0 +1,3987 @@ +#----------------------------------------------------------------------- +# TITLE: +# main1.tcl +# +# AUTHOR: +# Will Duquette +# +# DESCRIPTION: +# Snit's Not Incr Tcl, a simple object system in Pure Tcl. +# +# Snit 1.x Compiler and Run-Time Library, Tcl 8.4 and later +# +# Copyright (C) 2003-2006 by William H. Duquette +# This code is licensed as described in license.txt. +# +#----------------------------------------------------------------------- + +#----------------------------------------------------------------------- +# Namespace + +namespace eval ::snit:: { + namespace export \ + compile type widget widgetadaptor typemethod method macro +} + +#----------------------------------------------------------------------- +# Some Snit variables + +namespace eval ::snit:: { + variable reservedArgs {type selfns win self} + + # Widget classes which can be hulls (must have -class) + variable hulltypes { + toplevel tk::toplevel + frame tk::frame ttk::frame + labelframe tk::labelframe ttk::labelframe + } +} + +#----------------------------------------------------------------------- +# Snit Type Implementation template + +namespace eval ::snit:: { + # Template type definition: All internal and user-visible Snit + # implementation code. + # + # The following placeholders will automatically be replaced with + # the client's code, in two passes: + # + # First pass: + # %COMPILEDDEFS% The compiled type definition. + # + # Second pass: + # %TYPE% The fully qualified type name. + # %IVARDECS% Instance variable declarations + # %TVARDECS% Type variable declarations + # %TCONSTBODY% Type constructor body + # %INSTANCEVARS% The compiled instance variable initialization code. + # %TYPEVARS% The compiled type variable initialization code. + + # This is the overall type template. + variable typeTemplate + + # This is the normal type proc + variable nominalTypeProc + + # This is the "-hastypemethods no" type proc + variable simpleTypeProc +} + +set ::snit::typeTemplate { + + #------------------------------------------------------------------- + # The type's namespace definition and the user's type variables + + namespace eval %TYPE% {%TYPEVARS% + } + + #---------------------------------------------------------------- + # Commands for use in methods, typemethods, etc. + # + # These are implemented as aliases into the Snit runtime library. + + interp alias {} %TYPE%::installhull {} ::snit::RT.installhull %TYPE% + interp alias {} %TYPE%::install {} ::snit::RT.install %TYPE% + interp alias {} %TYPE%::typevariable {} ::variable + interp alias {} %TYPE%::variable {} ::snit::RT.variable + interp alias {} %TYPE%::mytypevar {} ::snit::RT.mytypevar %TYPE% + interp alias {} %TYPE%::typevarname {} ::snit::RT.mytypevar %TYPE% + interp alias {} %TYPE%::myvar {} ::snit::RT.myvar + interp alias {} %TYPE%::varname {} ::snit::RT.myvar + interp alias {} %TYPE%::codename {} ::snit::RT.codename %TYPE% + interp alias {} %TYPE%::myproc {} ::snit::RT.myproc %TYPE% + interp alias {} %TYPE%::mymethod {} ::snit::RT.mymethod + interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE% + interp alias {} %TYPE%::from {} ::snit::RT.from %TYPE% + + #------------------------------------------------------------------- + # Snit's internal variables + + namespace eval %TYPE% { + # Array: General Snit Info + # + # ns: The type's namespace + # hasinstances: T or F, from pragma -hasinstances. + # simpledispatch: T or F, from pragma -hasinstances. + # canreplace: T or F, from pragma -canreplace. + # counter: Count of instances created so far. + # widgetclass: Set by widgetclass statement. + # hulltype: Hull type (frame or toplevel) for widgets only. + # exceptmethods: Methods explicitly not delegated to * + # excepttypemethods: Methods explicitly not delegated to * + # tvardecs: Type variable declarations--for dynamic methods + # ivardecs: Instance variable declarations--for dyn. methods + typevariable Snit_info + set Snit_info(ns) %TYPE%:: + set Snit_info(hasinstances) 1 + set Snit_info(simpledispatch) 0 + set Snit_info(canreplace) 0 + set Snit_info(counter) 0 + set Snit_info(widgetclass) {} + set Snit_info(hulltype) frame + set Snit_info(exceptmethods) {} + set Snit_info(excepttypemethods) {} + set Snit_info(tvardecs) {%TVARDECS%} + set Snit_info(ivardecs) {%IVARDECS%} + + # Array: Public methods of this type. + # The index is the method name, or "*". + # The value is [list $pattern $componentName], where + # $componentName is "" for normal methods. + typevariable Snit_typemethodInfo + array unset Snit_typemethodInfo + + # Array: Public methods of instances of this type. + # The index is the method name, or "*". + # The value is [list $pattern $componentName], where + # $componentName is "" for normal methods. + typevariable Snit_methodInfo + array unset Snit_methodInfo + + # Array: option information. See dictionary.txt. + typevariable Snit_optionInfo + array unset Snit_optionInfo + set Snit_optionInfo(local) {} + set Snit_optionInfo(delegated) {} + set Snit_optionInfo(starcomp) {} + set Snit_optionInfo(except) {} + } + + #---------------------------------------------------------------- + # Compiled Procs + # + # These commands are created or replaced during compilation: + + + # Snit_instanceVars selfns + # + # Initializes the instance variables, if any. Called during + # instance creation. + + proc %TYPE%::Snit_instanceVars {selfns} { + %INSTANCEVARS% + } + + # Type Constructor + proc %TYPE%::Snit_typeconstructor {type} { + %TVARDECS% + %TCONSTBODY% + } + + #---------------------------------------------------------------- + # Default Procs + # + # These commands might be replaced during compilation: + + # Snit_destructor type selfns win self + # + # Default destructor for the type. By default, it does + # nothing. It's replaced by any user destructor. + # For types, it's called by method destroy; for widgettypes, + # it's called by a destroy event handler. + + proc %TYPE%::Snit_destructor {type selfns win self} { } + + #---------------------------------------------------------- + # Compiled Definitions + + %COMPILEDDEFS% + + #---------------------------------------------------------- + # Finally, call the Type Constructor + + %TYPE%::Snit_typeconstructor %TYPE% +} + +#----------------------------------------------------------------------- +# Type procs +# +# These procs expect the fully-qualified type name to be +# substituted in for %TYPE%. + +# This is the nominal type proc. It supports typemethods and +# delegated typemethods. +set ::snit::nominalTypeProc { + # Type dispatcher function. Note: This function lives + # in the parent of the %TYPE% namespace! All accesses to + # %TYPE% variables and methods must be qualified! + proc %TYPE% {{method ""} args} { + # First, if there's no method, and no args, and there's a create + # method, and this isn't a widget, then method is "create" and + # "args" is %AUTO%. + if {"" == $method && [llength $args] == 0} { + ::variable %TYPE%::Snit_info + + if {$Snit_info(hasinstances) && !$Snit_info(isWidget)} { + set method create + lappend args %AUTO% + } else { + error "wrong \# args: should be \"%TYPE% method args\"" + } + } + + # Next, retrieve the command. + variable %TYPE%::Snit_typemethodCache + while 1 { + if {[catch {set Snit_typemethodCache($method)} commandRec]} { + set commandRec [::snit::RT.CacheTypemethodCommand %TYPE% $method] + + if {[llength $commandRec] == 0} { + return -code error "\"%TYPE% $method\" is not defined" + } + } + + # If we've got a real command, break. + if {[lindex $commandRec 0] == 0} { + break + } + + # Otherwise, we need to look up again...if we can. + if {[llength $args] == 0} { + return -code error \ + "wrong number args: should be \"%TYPE% $method method args\"" + } + + lappend method [lindex $args 0] + set args [lrange $args 1 end] + } + + set command [lindex $commandRec 1] + + # Pass along the return code unchanged. + set retval [catch {uplevel 1 $command $args} result] + + if {$retval} { + if {$retval == 1} { + global errorInfo + global errorCode + return -code error -errorinfo $errorInfo \ + -errorcode $errorCode $result + } else { + return -code $retval $result + } + } + + return $result + } +} + +# This is the simplified type proc for when there are no typemethods +# except create. In this case, it doesn't take a method argument; +# the method is always "create". +set ::snit::simpleTypeProc { + # Type dispatcher function. Note: This function lives + # in the parent of the %TYPE% namespace! All accesses to + # %TYPE% variables and methods must be qualified! + proc %TYPE% {args} { + ::variable %TYPE%::Snit_info + + # FIRST, if the are no args, the single arg is %AUTO% + if {[llength $args] == 0} { + if {$Snit_info(isWidget)} { + error "wrong \# args: should be \"%TYPE% name args\"" + } + + lappend args %AUTO% + } + + # NEXT, we're going to call the create method. + # Pass along the return code unchanged. + if {$Snit_info(isWidget)} { + set command [list ::snit::RT.widget.typemethod.create %TYPE%] + } else { + set command [list ::snit::RT.type.typemethod.create %TYPE%] + } + + set retval [catch {uplevel 1 $command $args} result] + + if {$retval} { + if {$retval == 1} { + global errorInfo + global errorCode + return -code error -errorinfo $errorInfo \ + -errorcode $errorCode $result + } else { + return -code $retval $result + } + } + + return $result + } +} + +#----------------------------------------------------------------------- +# Instance procs +# +# The following must be substituted into these proc bodies: +# +# %SELFNS% The instance namespace +# %WIN% The original instance name +# %TYPE% The fully-qualified type name +# + +# Nominal instance proc body: supports method caching and delegation. +# +# proc $instanceName {method args} .... +set ::snit::nominalInstanceProc { + set self [set %SELFNS%::Snit_instance] + + while {1} { + if {[catch {set %SELFNS%::Snit_methodCache($method)} commandRec]} { + set commandRec [snit::RT.CacheMethodCommand %TYPE% %SELFNS% %WIN% $self $method] + + if {[llength $commandRec] == 0} { + return -code error \ + "\"$self $method\" is not defined" + } + } + + # If we've got a real command, break. + if {[lindex $commandRec 0] == 0} { + break + } + + # Otherwise, we need to look up again...if we can. + if {[llength $args] == 0} { + return -code error \ + "wrong number args: should be \"$self $method method args\"" + } + + lappend method [lindex $args 0] + set args [lrange $args 1 end] + } + + set command [lindex $commandRec 1] + + # Pass along the return code unchanged. + set retval [catch {uplevel 1 $command $args} result] + + if {$retval} { + if {$retval == 1} { + global errorInfo + global errorCode + return -code error -errorinfo $errorInfo \ + -errorcode $errorCode $result + } else { + return -code $retval $result + } + } + + return $result +} + +# Simplified method proc body: No delegation allowed; no support for +# upvar or exotic return codes or hierarchical methods. Designed for +# max speed for simple types. +# +# proc $instanceName {method args} .... + +set ::snit::simpleInstanceProc { + set self [set %SELFNS%::Snit_instance] + + if {[lsearch -exact ${%TYPE%::Snit_methods} $method] == -1} { + set optlist [join ${%TYPE%::Snit_methods} ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$method\": must be $optlist" + } + + eval [linsert $args 0 \ + %TYPE%::Snit_method$method %TYPE% %SELFNS% %WIN% $self] +} + + +#======================================================================= +# Snit Type Definition +# +# These are the procs used to define Snit types, widgets, and +# widgetadaptors. + + +#----------------------------------------------------------------------- +# Snit Compilation Variables +# +# The following variables are used while Snit is compiling a type, +# and are disposed afterwards. + +namespace eval ::snit:: { + # The compiler variable contains the name of the slave interpreter + # used to compile type definitions. + variable compiler "" + + # The compile array accumulates information about the type or + # widgettype being compiled. It is cleared before and after each + # compilation. It has these indices: + # + # type: The name of the type being compiled, for use + # in compilation procs. + # defs: Compiled definitions, both standard and client. + # which: type, widget, widgetadaptor + # instancevars: Instance variable definitions and initializations. + # ivprocdec: Instance variable proc declarations. + # tvprocdec: Type variable proc declarations. + # typeconstructor: Type constructor body. + # widgetclass: The widgetclass, for snit::widgets, only + # hasoptions: False, initially; set to true when first + # option is defined. + # localoptions: Names of local options. + # delegatedoptions: Names of delegated options. + # localmethods: Names of locally defined methods. + # delegatesmethods: no if no delegated methods, yes otherwise. + # hashierarchic : no if no hierarchic methods, yes otherwise. + # components: Names of defined components. + # typecomponents: Names of defined typecomponents. + # typevars: Typevariable definitions and initializations. + # varnames: Names of instance variables + # typevarnames Names of type variables + # hasconstructor False, initially; true when constructor is + # defined. + # resource-$opt The option's resource name + # class-$opt The option's class + # -default-$opt The option's default value + # -validatemethod-$opt The option's validate method + # -configuremethod-$opt The option's configure method + # -cgetmethod-$opt The option's cget method. + # -hastypeinfo The -hastypeinfo pragma + # -hastypedestroy The -hastypedestroy pragma + # -hastypemethods The -hastypemethods pragma + # -hasinfo The -hasinfo pragma + # -hasinstances The -hasinstances pragma + # -simpledispatch The -simpledispatch pragma + # -canreplace The -canreplace pragma + variable compile + + # This variable accumulates method dispatch information; it has + # the same structure as the %TYPE%::Snit_methodInfo array, and is + # used to initialize it. + variable methodInfo + + # This variable accumulates typemethod dispatch information; it has + # the same structure as the %TYPE%::Snit_typemethodInfo array, and is + # used to initialize it. + variable typemethodInfo + + # The following variable lists the reserved type definition statement + # names, e.g., the names you can't use as macros. It's built at + # compiler definition time using "info commands". + variable reservedwords {} +} + +#----------------------------------------------------------------------- +# type compilation commands +# +# The type and widgettype commands use a slave interpreter to compile +# the type definition. These are the procs +# that are aliased into it. + +# Initialize the compiler +proc ::snit::Comp.Init {} { + variable compiler + variable reservedwords + + if {"" == $compiler} { + # Create the compiler's interpreter + set compiler [interp create] + + # Initialize the interpreter + $compiler eval { + catch {close stdout} + catch {close stderr} + catch {close stdin} + + # Load package information + # TBD: see if this can be moved outside. + # @mdgen NODEP: ::snit::__does_not_exist__ + catch {package require ::snit::__does_not_exist__} + + # Protect some Tcl commands our type definitions + # will shadow. + rename proc _proc + rename variable _variable + } + + # Define compilation aliases. + $compiler alias pragma ::snit::Comp.statement.pragma + $compiler alias widgetclass ::snit::Comp.statement.widgetclass + $compiler alias hulltype ::snit::Comp.statement.hulltype + $compiler alias constructor ::snit::Comp.statement.constructor + $compiler alias destructor ::snit::Comp.statement.destructor + $compiler alias option ::snit::Comp.statement.option + $compiler alias oncget ::snit::Comp.statement.oncget + $compiler alias onconfigure ::snit::Comp.statement.onconfigure + $compiler alias method ::snit::Comp.statement.method + $compiler alias typemethod ::snit::Comp.statement.typemethod + $compiler alias typeconstructor ::snit::Comp.statement.typeconstructor + $compiler alias proc ::snit::Comp.statement.proc + $compiler alias typevariable ::snit::Comp.statement.typevariable + $compiler alias variable ::snit::Comp.statement.variable + $compiler alias typecomponent ::snit::Comp.statement.typecomponent + $compiler alias component ::snit::Comp.statement.component + $compiler alias delegate ::snit::Comp.statement.delegate + $compiler alias expose ::snit::Comp.statement.expose + + # Get the list of reserved words + set reservedwords [$compiler eval {info commands}] + } +} + +# Compile a type definition, and return the results as a list of two +# items: the fully-qualified type name, and a script that will define +# the type when executed. +# +# which type, widget, or widgetadaptor +# type the type name +# body the type definition +proc ::snit::Comp.Compile {which type body} { + variable typeTemplate + variable nominalTypeProc + variable simpleTypeProc + variable compile + variable compiler + variable methodInfo + variable typemethodInfo + + # FIRST, qualify the name. + if {![string match "::*" $type]} { + # Get caller's namespace; + # append :: if not global namespace. + set ns [uplevel 2 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set type "$ns$type" + } + + # NEXT, create and initialize the compiler, if needed. + Comp.Init + + # NEXT, initialize the class data + array unset methodInfo + array unset typemethodInfo + + array unset compile + set compile(type) $type + set compile(defs) {} + set compile(which) $which + set compile(hasoptions) no + set compile(localoptions) {} + set compile(instancevars) {} + set compile(typevars) {} + set compile(delegatedoptions) {} + set compile(ivprocdec) {} + set compile(tvprocdec) {} + set compile(typeconstructor) {} + set compile(widgetclass) {} + set compile(hulltype) {} + set compile(localmethods) {} + set compile(delegatesmethods) no + set compile(hashierarchic) no + set compile(components) {} + set compile(typecomponents) {} + set compile(varnames) {} + set compile(typevarnames) {} + set compile(hasconstructor) no + set compile(-hastypedestroy) yes + set compile(-hastypeinfo) yes + set compile(-hastypemethods) yes + set compile(-hasinfo) yes + set compile(-hasinstances) yes + set compile(-simpledispatch) no + set compile(-canreplace) no + + set isWidget [string match widget* $which] + set isWidgetAdaptor [string match widgetadaptor $which] + + # NEXT, Evaluate the type's definition in the class interpreter. + $compiler eval $body + + # NEXT, Add the standard definitions + append compile(defs) \ + "\nset %TYPE%::Snit_info(isWidget) $isWidget\n" + + append compile(defs) \ + "\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n" + + # Indicate whether the type can create instances that replace + # existing commands. + append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n" + + + # Check pragmas for conflict. + + if {!$compile(-hastypemethods) && !$compile(-hasinstances)} { + error "$which $type has neither typemethods nor instances" + } + + if {$compile(-simpledispatch) && $compile(delegatesmethods)} { + error "$which $type requests -simpledispatch but delegates methods." + } + + if {$compile(-simpledispatch) && $compile(hashierarchic)} { + error "$which $type requests -simpledispatch but defines hierarchical methods." + } + + # If there are typemethods, define the standard typemethods and + # the nominal type proc. Otherwise define the simple type proc. + if {$compile(-hastypemethods)} { + # Add the info typemethod unless the pragma forbids it. + if {$compile(-hastypeinfo)} { + Comp.statement.delegate typemethod info \ + using {::snit::RT.typemethod.info %t} + } + + # Add the destroy typemethod unless the pragma forbids it. + if {$compile(-hastypedestroy)} { + Comp.statement.delegate typemethod destroy \ + using {::snit::RT.typemethod.destroy %t} + } + + # Add the nominal type proc. + append compile(defs) $nominalTypeProc + } else { + # Add the simple type proc. + append compile(defs) $simpleTypeProc + } + + # Add standard methods/typemethods that only make sense if the + # type has instances. + if {$compile(-hasinstances)} { + # If we're using simple dispatch, remember that. + if {$compile(-simpledispatch)} { + append compile(defs) "\nset %TYPE%::Snit_info(simpledispatch) 1\n" + } + + # Add the info method unless the pragma forbids it. + if {$compile(-hasinfo)} { + if {!$compile(-simpledispatch)} { + Comp.statement.delegate method info \ + using {::snit::RT.method.info %t %n %w %s} + } else { + Comp.statement.method info {args} { + eval [linsert $args 0 \ + ::snit::RT.method.info $type $selfns $win $self] + } + } + } + + # Add the option handling stuff if there are any options. + if {$compile(hasoptions)} { + Comp.statement.variable options + + if {!$compile(-simpledispatch)} { + Comp.statement.delegate method cget \ + using {::snit::RT.method.cget %t %n %w %s} + Comp.statement.delegate method configurelist \ + using {::snit::RT.method.configurelist %t %n %w %s} + Comp.statement.delegate method configure \ + using {::snit::RT.method.configure %t %n %w %s} + } else { + Comp.statement.method cget {args} { + eval [linsert $args 0 \ + ::snit::RT.method.cget $type $selfns $win $self] + } + Comp.statement.method configurelist {args} { + eval [linsert $args 0 \ + ::snit::RT.method.configurelist $type $selfns $win $self] + } + Comp.statement.method configure {args} { + eval [linsert $args 0 \ + ::snit::RT.method.configure $type $selfns $win $self] + } + } + } + + # Add a default constructor, if they haven't already defined one. + # If there are options, it will configure args; otherwise it + # will do nothing. + if {!$compile(hasconstructor)} { + if {$compile(hasoptions)} { + Comp.statement.constructor {args} { + $self configurelist $args + } + } else { + Comp.statement.constructor {} {} + } + } + + if {!$isWidget} { + if {!$compile(-simpledispatch)} { + Comp.statement.delegate method destroy \ + using {::snit::RT.method.destroy %t %n %w %s} + } else { + Comp.statement.method destroy {args} { + eval [linsert $args 0 \ + ::snit::RT.method.destroy $type $selfns $win $self] + } + } + + Comp.statement.delegate typemethod create \ + using {::snit::RT.type.typemethod.create %t} + } else { + Comp.statement.delegate typemethod create \ + using {::snit::RT.widget.typemethod.create %t} + } + + # Save the list of method names, for -simpledispatch; otherwise, + # save the method info. + if {$compile(-simpledispatch)} { + append compile(defs) \ + "\nset %TYPE%::Snit_methods [list $compile(localmethods)]\n" + } else { + append compile(defs) \ + "\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n" + } + + } else { + append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n" + } + + # NEXT, compiling the type definition built up a set of information + # about the type's locally defined options; add this information to + # the compiled definition. + Comp.SaveOptionInfo + + # NEXT, compiling the type definition built up a set of information + # about the typemethods; save the typemethod info. + append compile(defs) \ + "\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n" + + # NEXT, if this is a widget define the hull component if it isn't + # already defined. + if {$isWidget} { + Comp.DefineComponent hull + } + + # NEXT, substitute the compiled definition into the type template + # to get the type definition script. + set defscript [Expand $typeTemplate \ + %COMPILEDDEFS% $compile(defs)] + + # NEXT, substitute the defined macros into the type definition script. + # This is done as a separate step so that the compile(defs) can + # contain the macros defined below. + + set defscript [Expand $defscript \ + %TYPE% $type \ + %IVARDECS% $compile(ivprocdec) \ + %TVARDECS% $compile(tvprocdec) \ + %TCONSTBODY% $compile(typeconstructor) \ + %INSTANCEVARS% $compile(instancevars) \ + %TYPEVARS% $compile(typevars) \ + ] + + array unset compile + + return [list $type $defscript] +} + +# Information about locally-defined options is accumulated during +# compilation, but not added to the compiled definition--the option +# statement can appear multiple times, so it's easier this way. +# This proc fills in Snit_optionInfo with the accumulated information. +# +# It also computes the option's resource and class names if needed. +# +# Note that the information for delegated options was put in +# Snit_optionInfo during compilation. + +proc ::snit::Comp.SaveOptionInfo {} { + variable compile + + foreach option $compile(localoptions) { + if {"" == $compile(resource-$option)} { + set compile(resource-$option) [string range $option 1 end] + } + + if {"" == $compile(class-$option)} { + set compile(class-$option) [Capitalize $compile(resource-$option)] + } + + # NOTE: Don't verify that the validate, configure, and cget + # values name real methods; the methods might be defined outside + # the typedefinition using snit::method. + + Mappend compile(defs) { + # Option %OPTION% + lappend %TYPE%::Snit_optionInfo(local) %OPTION% + + set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 1 + set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RESOURCE% + set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS% + set %TYPE%::Snit_optionInfo(default-%OPTION%) %DEFAULT% + set %TYPE%::Snit_optionInfo(validate-%OPTION%) %VALIDATE% + set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE% + set %TYPE%::Snit_optionInfo(cget-%OPTION%) %CGET% + set %TYPE%::Snit_optionInfo(readonly-%OPTION%) %READONLY% + set %TYPE%::Snit_optionInfo(typespec-%OPTION%) %TYPESPEC% + } %OPTION% $option \ + %RESOURCE% $compile(resource-$option) \ + %CLASS% $compile(class-$option) \ + %DEFAULT% [list $compile(-default-$option)] \ + %VALIDATE% [list $compile(-validatemethod-$option)] \ + %CONFIGURE% [list $compile(-configuremethod-$option)] \ + %CGET% [list $compile(-cgetmethod-$option)] \ + %READONLY% $compile(-readonly-$option) \ + %TYPESPEC% [list $compile(-type-$option)] + } +} + + +# Evaluates a compiled type definition, thus making the type available. +proc ::snit::Comp.Define {compResult} { + # The compilation result is a list containing the fully qualified + # type name and a script to evaluate to define the type. + set type [lindex $compResult 0] + set defscript [lindex $compResult 1] + + # Execute the type definition script. + # Consider using namespace eval %TYPE%. See if it's faster. + if {[catch {eval $defscript} result]} { + namespace delete $type + catch {rename $type ""} + error $result + } + + return $type +} + +# Sets pragma options which control how the type is defined. +proc ::snit::Comp.statement.pragma {args} { + variable compile + + set errRoot "Error in \"pragma...\"" + + foreach {opt val} $args { + switch -exact -- $opt { + -hastypeinfo - + -hastypedestroy - + -hastypemethods - + -hasinstances - + -simpledispatch - + -hasinfo - + -canreplace { + if {![string is boolean -strict $val]} { + error "$errRoot, \"$opt\" requires a boolean value" + } + set compile($opt) $val + } + default { + error "$errRoot, unknown pragma" + } + } + } +} + +# Defines a widget's option class name. +# This statement is only available for snit::widgets, +# not for snit::types or snit::widgetadaptors. +proc ::snit::Comp.statement.widgetclass {name} { + variable compile + + # First, widgetclass can only be set for true widgets + if {"widget" != $compile(which)} { + error "widgetclass cannot be set for snit::$compile(which)s" + } + + # Next, validate the option name. We'll require that it begin + # with an uppercase letter. + set initial [string index $name 0] + if {![string is upper $initial]} { + error "widgetclass \"$name\" does not begin with an uppercase letter" + } + + if {"" != $compile(widgetclass)} { + error "too many widgetclass statements" + } + + # Next, save it. + Mappend compile(defs) { + set %TYPE%::Snit_info(widgetclass) %WIDGETCLASS% + } %WIDGETCLASS% [list $name] + + set compile(widgetclass) $name +} + +# Defines a widget's hull type. +# This statement is only available for snit::widgets, +# not for snit::types or snit::widgetadaptors. +proc ::snit::Comp.statement.hulltype {name} { + variable compile + variable hulltypes + + # First, hulltype can only be set for true widgets + if {"widget" != $compile(which)} { + error "hulltype cannot be set for snit::$compile(which)s" + } + + # Next, it must be one of the valid hulltypes (frame, toplevel, ...) + if {[lsearch -exact $hulltypes [string trimleft $name :]] == -1} { + error "invalid hulltype \"$name\", should be one of\ + [join $hulltypes {, }]" + } + + if {"" != $compile(hulltype)} { + error "too many hulltype statements" + } + + # Next, save it. + Mappend compile(defs) { + set %TYPE%::Snit_info(hulltype) %HULLTYPE% + } %HULLTYPE% $name + + set compile(hulltype) $name +} + +# Defines a constructor. +proc ::snit::Comp.statement.constructor {arglist body} { + variable compile + + CheckArgs "constructor" $arglist + + # Next, add a magic reference to self. + set arglist [concat type selfns win self $arglist] + + # Next, add variable declarations to body: + set body "%TVARDECS%%IVARDECS%\n$body" + + set compile(hasconstructor) yes + append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n" +} + +# Defines a destructor. +proc ::snit::Comp.statement.destructor {body} { + variable compile + + # Next, add variable declarations to body: + set body "%TVARDECS%%IVARDECS%\n$body" + + append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]\n\n" +} + +# Defines a type option. The option value can be a triple, specifying +# the option's -name, resource name, and class name. +proc ::snit::Comp.statement.option {optionDef args} { + variable compile + + # First, get the three option names. + set option [lindex $optionDef 0] + set resourceName [lindex $optionDef 1] + set className [lindex $optionDef 2] + + set errRoot "Error in \"option [list $optionDef]...\"" + + # Next, validate the option name. + if {![Comp.OptionNameIsValid $option]} { + error "$errRoot, badly named option \"$option\"" + } + + if {[Contains $option $compile(delegatedoptions)]} { + error "$errRoot, cannot define \"$option\" locally, it has been delegated" + } + + if {![Contains $option $compile(localoptions)]} { + # Remember that we've seen this one. + set compile(hasoptions) yes + lappend compile(localoptions) $option + + # Initialize compilation info for this option. + set compile(resource-$option) "" + set compile(class-$option) "" + set compile(-default-$option) "" + set compile(-validatemethod-$option) "" + set compile(-configuremethod-$option) "" + set compile(-cgetmethod-$option) "" + set compile(-readonly-$option) 0 + set compile(-type-$option) "" + } + + # NEXT, see if we have a resource name. If so, make sure it + # isn't being redefined differently. + if {"" != $resourceName} { + if {"" == $compile(resource-$option)} { + # If it's undefined, just save the value. + set compile(resource-$option) $resourceName + } elseif {![string equal $resourceName $compile(resource-$option)]} { + # It's been redefined differently. + error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\"" + } + } + + # NEXT, see if we have a class name. If so, make sure it + # isn't being redefined differently. + if {"" != $className} { + if {"" == $compile(class-$option)} { + # If it's undefined, just save the value. + set compile(class-$option) $className + } elseif {![string equal $className $compile(class-$option)]} { + # It's been redefined differently. + error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\"" + } + } + + # NEXT, handle the args; it's not an error to redefine these. + if {[llength $args] == 1} { + set compile(-default-$option) [lindex $args 0] + } else { + foreach {optopt val} $args { + switch -exact -- $optopt { + -default - + -validatemethod - + -configuremethod - + -cgetmethod { + set compile($optopt-$option) $val + } + -type { + set compile($optopt-$option) $val + + if {[llength $val] == 1} { + # The type spec *is* the validation object + append compile(defs) \ + "\nset %TYPE%::Snit_optionInfo(typeobj-$option) [list $val]\n" + } else { + # Compilation the creation of the validation object + set cmd [linsert $val 1 %TYPE%::Snit_TypeObj_%AUTO%] + append compile(defs) \ + "\nset %TYPE%::Snit_optionInfo(typeobj-$option) \[$cmd\]\n" + } + } + -readonly { + if {![string is boolean -strict $val]} { + error "$errRoot, -readonly requires a boolean, got \"$val\"" + } + set compile($optopt-$option) $val + } + default { + error "$errRoot, unknown option definition option \"$optopt\"" + } + } + } + } +} + +# 1 if the option name is valid, 0 otherwise. +proc ::snit::Comp.OptionNameIsValid {option} { + if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} { + return 0 + } + + return 1 +} + +# Defines an option's cget handler +proc ::snit::Comp.statement.oncget {option body} { + variable compile + + set errRoot "Error in \"oncget $option...\"" + + if {[lsearch -exact $compile(delegatedoptions) $option] != -1} { + return -code error "$errRoot, option \"$option\" is delegated" + } + + if {[lsearch -exact $compile(localoptions) $option] == -1} { + return -code error "$errRoot, option \"$option\" unknown" + } + + Comp.statement.method _cget$option {_option} $body + Comp.statement.option $option -cgetmethod _cget$option +} + +# Defines an option's configure handler. +proc ::snit::Comp.statement.onconfigure {option arglist body} { + variable compile + + if {[lsearch -exact $compile(delegatedoptions) $option] != -1} { + return -code error "onconfigure $option: option \"$option\" is delegated" + } + + if {[lsearch -exact $compile(localoptions) $option] == -1} { + return -code error "onconfigure $option: option \"$option\" unknown" + } + + if {[llength $arglist] != 1} { + error \ + "onconfigure $option handler should have one argument, got \"$arglist\"" + } + + CheckArgs "onconfigure $option" $arglist + + # Next, add a magic reference to the option name + set arglist [concat _option $arglist] + + Comp.statement.method _configure$option $arglist $body + Comp.statement.option $option -configuremethod _configure$option +} + +# Defines an instance method. +proc ::snit::Comp.statement.method {method arglist body} { + variable compile + variable methodInfo + + # FIRST, check the method name against previously defined + # methods. + Comp.CheckMethodName $method 0 ::snit::methodInfo \ + "Error in \"method [list $method]...\"" + + if {[llength $method] > 1} { + set compile(hashierarchic) yes + } + + # Remeber this method + lappend compile(localmethods) $method + + CheckArgs "method [list $method]" $arglist + + # Next, add magic references to type and self. + set arglist [concat type selfns win self $arglist] + + # Next, add variable declarations to body: + set body "%TVARDECS%%IVARDECS%\n# END snit method prolog\n$body" + + # Next, save the definition script. + if {[llength $method] == 1} { + set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""} + Mappend compile(defs) { + proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY% + } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body] + } else { + set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""} + + Mappend compile(defs) { + proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY% + } %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \ + %BODY% [list $body] + } +} + +# Check for name collisions; save prefix information. +# +# method The name of the method or typemethod. +# delFlag 1 if delegated, 0 otherwise. +# infoVar The fully qualified name of the array containing +# information about the defined methods. +# errRoot The root string for any error messages. + +proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} { + upvar $infoVar methodInfo + + # FIRST, make sure the method name is a valid Tcl list. + if {[catch {lindex $method 0}]} { + error "$errRoot, the name \"$method\" must have list syntax." + } + + # NEXT, check whether we can define it. + if {![catch {set methodInfo($method)} data]} { + # We can't redefine methods with submethods. + if {[lindex $data 0] == 1} { + error "$errRoot, \"$method\" has submethods." + } + + # You can't delegate a method that's defined locally, + # and you can't define a method locally if it's been delegated. + if {$delFlag && "" == [lindex $data 2]} { + error "$errRoot, \"$method\" has been defined locally." + } elseif {!$delFlag && "" != [lindex $data 2]} { + error "$errRoot, \"$method\" has been delegated" + } + } + + # Handle hierarchical case. + if {[llength $method] > 1} { + set prefix {} + set tokens $method + while {[llength $tokens] > 1} { + lappend prefix [lindex $tokens 0] + set tokens [lrange $tokens 1 end] + + if {![catch {set methodInfo($prefix)} result]} { + # Prefix is known. If it's not a prefix, throw an + # error. + if {[lindex $result 0] == 0} { + error "$errRoot, \"$prefix\" has no submethods." + } + } + + set methodInfo($prefix) [list 1] + } + } +} + +# Defines a typemethod method. +proc ::snit::Comp.statement.typemethod {method arglist body} { + variable compile + variable typemethodInfo + + # FIRST, check the typemethod name against previously defined + # typemethods. + Comp.CheckMethodName $method 0 ::snit::typemethodInfo \ + "Error in \"typemethod [list $method]...\"" + + CheckArgs "typemethod $method" $arglist + + # First, add magic reference to type. + set arglist [concat type $arglist] + + # Next, add typevariable declarations to body: + set body "%TVARDECS%\n# END snit method prolog\n$body" + + # Next, save the definition script + if {[llength $method] == 1} { + set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""} + + Mappend compile(defs) { + proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY% + } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body] + } else { + set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""} + + Mappend compile(defs) { + proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY% + } %JMETHOD% [join $method _] \ + %ARGLIST% [list $arglist] %BODY% [list $body] + } +} + + +# Defines a type constructor. +proc ::snit::Comp.statement.typeconstructor {body} { + variable compile + + if {"" != $compile(typeconstructor)} { + error "too many typeconstructors" + } + + set compile(typeconstructor) $body +} + +# Defines a static proc in the type's namespace. +proc ::snit::Comp.statement.proc {proc arglist body} { + variable compile + + # If "ns" is defined, the proc can see instance variables. + if {[lsearch -exact $arglist selfns] != -1} { + # Next, add instance variable declarations to body: + set body "%IVARDECS%\n$body" + } + + # The proc can always see typevariables. + set body "%TVARDECS%\n$body" + + append compile(defs) " + + # Proc $proc + proc [list %TYPE%::$proc $arglist $body] + " +} + +# Defines a static variable in the type's namespace. +proc ::snit::Comp.statement.typevariable {name args} { + variable compile + + set errRoot "Error in \"typevariable $name...\"" + + set len [llength $args] + + if {$len > 2 || + ($len == 2 && "-array" != [lindex $args 0])} { + error "$errRoot, too many initializers" + } + + if {[lsearch -exact $compile(varnames) $name] != -1} { + error "$errRoot, \"$name\" is already an instance variable" + } + + lappend compile(typevarnames) $name + + if {$len == 1} { + append compile(typevars) \ + "\n\t [list ::variable $name [lindex $args 0]]" + } elseif {$len == 2} { + append compile(typevars) \ + "\n\t [list ::variable $name]" + append compile(typevars) \ + "\n\t [list array set $name [lindex $args 1]]" + } else { + append compile(typevars) \ + "\n\t [list ::variable $name]" + } + + append compile(tvprocdec) "\n\t typevariable ${name}" +} + +# Defines an instance variable; the definition will go in the +# type's create typemethod. +proc ::snit::Comp.statement.variable {name args} { + variable compile + + set errRoot "Error in \"variable $name...\"" + + set len [llength $args] + + if {$len > 2 || + ($len == 2 && "-array" != [lindex $args 0])} { + error "$errRoot, too many initializers" + } + + if {[lsearch -exact $compile(typevarnames) $name] != -1} { + error "$errRoot, \"$name\" is already a typevariable" + } + + lappend compile(varnames) $name + + if {$len == 1} { + append compile(instancevars) \ + "\nset \${selfns}::$name [list [lindex $args 0]]\n" + } elseif {$len == 2} { + append compile(instancevars) \ + "\narray set \${selfns}::$name [list [lindex $args 1]]\n" + } + + append compile(ivprocdec) "\n\t " + Mappend compile(ivprocdec) {::variable ${selfns}::%N} %N $name +} + +# Defines a typecomponent, and handles component options. +# +# component The logical name of the delegate +# args options. + +proc ::snit::Comp.statement.typecomponent {component args} { + variable compile + + set errRoot "Error in \"typecomponent $component...\"" + + # FIRST, define the component + Comp.DefineTypecomponent $component $errRoot + + # NEXT, handle the options. + set publicMethod "" + set inheritFlag 0 + + foreach {opt val} $args { + switch -exact -- $opt { + -public { + set publicMethod $val + } + -inherit { + set inheritFlag $val + if {![string is boolean $inheritFlag]} { + error "typecomponent $component -inherit: expected boolean value, got \"$val\"" + } + } + default { + error "typecomponent $component: Invalid option \"$opt\"" + } + } + } + + # NEXT, if -public specified, define the method. + if {"" != $publicMethod} { + Comp.statement.delegate typemethod [list $publicMethod *] to $component + } + + # NEXT, if "-inherit 1" is specified, delegate typemethod * to + # this component. + if {$inheritFlag} { + Comp.statement.delegate typemethod "*" to $component + } + +} + + +# Defines a name to be a typecomponent +# +# The name becomes a typevariable; in addition, it gets a +# write trace so that when it is set, all of the component mechanisms +# get updated. +# +# component The component name + +proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} { + variable compile + + if {[lsearch -exact $compile(varnames) $component] != -1} { + error "$errRoot, \"$component\" is already an instance variable" + } + + if {[lsearch -exact $compile(typecomponents) $component] == -1} { + # Remember we've done this. + lappend compile(typecomponents) $component + + # Make it a type variable with no initial value + Comp.statement.typevariable $component "" + + # Add a write trace to do the component thing. + Mappend compile(typevars) { + trace add variable %COMP% write \ + [list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%] + } %TYPE% $compile(type) %COMP% $component + } +} + +# Defines a component, and handles component options. +# +# component The logical name of the delegate +# args options. +# +# TBD: Ideally, it should be possible to call this statement multiple +# times, possibly changing the option values. To do that, I'd need +# to cache the option values and not act on them until *after* I'd +# read the entire type definition. + +proc ::snit::Comp.statement.component {component args} { + variable compile + + set errRoot "Error in \"component $component...\"" + + # FIRST, define the component + Comp.DefineComponent $component $errRoot + + # NEXT, handle the options. + set publicMethod "" + set inheritFlag 0 + + foreach {opt val} $args { + switch -exact -- $opt { + -public { + set publicMethod $val + } + -inherit { + set inheritFlag $val + if {![string is boolean $inheritFlag]} { + error "component $component -inherit: expected boolean value, got \"$val\"" + } + } + default { + error "component $component: Invalid option \"$opt\"" + } + } + } + + # NEXT, if -public specified, define the method. + if {"" != $publicMethod} { + Comp.statement.delegate method [list $publicMethod *] to $component + } + + # NEXT, if -inherit is specified, delegate method/option * to + # this component. + if {$inheritFlag} { + Comp.statement.delegate method "*" to $component + Comp.statement.delegate option "*" to $component + } +} + + +# Defines a name to be a component +# +# The name becomes an instance variable; in addition, it gets a +# write trace so that when it is set, all of the component mechanisms +# get updated. +# +# component The component name + +proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} { + variable compile + + if {[lsearch -exact $compile(typevarnames) $component] != -1} { + error "$errRoot, \"$component\" is already a typevariable" + } + + if {[lsearch -exact $compile(components) $component] == -1} { + # Remember we've done this. + lappend compile(components) $component + + # Make it an instance variable with no initial value + Comp.statement.variable $component "" + + # Add a write trace to do the component thing. + Mappend compile(instancevars) { + trace add variable ${selfns}::%COMP% write \ + [list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%] + } %TYPE% $compile(type) %COMP% $component + } +} + +# Creates a delegated method, typemethod, or option. +proc ::snit::Comp.statement.delegate {what name args} { + # FIRST, dispatch to correct handler. + switch $what { + typemethod { Comp.DelegatedTypemethod $name $args } + method { Comp.DelegatedMethod $name $args } + option { Comp.DelegatedOption $name $args } + default { + error "Error in \"delegate $what $name...\", \"$what\"?" + } + } + + if {([llength $args] % 2) != 0} { + error "Error in \"delegate $what $name...\", invalid syntax" + } +} + +# Creates a delegated typemethod delegating it to a particular +# typecomponent or an arbitrary command. +# +# method The name of the method +# arglist Delegation options + +proc ::snit::Comp.DelegatedTypemethod {method arglist} { + variable compile + variable typemethodInfo + + set errRoot "Error in \"delegate typemethod [list $method]...\"" + + # Next, parse the delegation options. + set component "" + set target "" + set exceptions {} + set pattern "" + set methodTail [lindex $method end] + + foreach {opt value} $arglist { + switch -exact $opt { + to { set component $value } + as { set target $value } + except { set exceptions $value } + using { set pattern $value } + default { + error "$errRoot, unknown delegation option \"$opt\"" + } + } + } + + if {"" == $component && "" == $pattern} { + error "$errRoot, missing \"to\"" + } + + if {"*" == $methodTail && "" != $target} { + error "$errRoot, cannot specify \"as\" with \"*\"" + } + + if {"*" != $methodTail && "" != $exceptions} { + error "$errRoot, can only specify \"except\" with \"*\"" + } + + if {"" != $pattern && "" != $target} { + error "$errRoot, cannot specify both \"as\" and \"using\"" + } + + foreach token [lrange $method 1 end-1] { + if {"*" == $token} { + error "$errRoot, \"*\" must be the last token." + } + } + + # NEXT, define the component + if {"" != $component} { + Comp.DefineTypecomponent $component $errRoot + } + + # NEXT, define the pattern. + if {"" == $pattern} { + if {"*" == $methodTail} { + set pattern "%c %m" + } elseif {"" != $target} { + set pattern "%c $target" + } else { + set pattern "%c %m" + } + } + + # Make sure the pattern is a valid list. + if {[catch {lindex $pattern 0} result]} { + error "$errRoot, the using pattern, \"$pattern\", is not a valid list" + } + + # NEXT, check the method name against previously defined + # methods. + Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot + + set typemethodInfo($method) [list 0 $pattern $component] + + if {[string equal $methodTail "*"]} { + Mappend compile(defs) { + set %TYPE%::Snit_info(excepttypemethods) %EXCEPT% + } %EXCEPT% [list $exceptions] + } +} + + +# Creates a delegated method delegating it to a particular +# component or command. +# +# method The name of the method +# arglist Delegation options. + +proc ::snit::Comp.DelegatedMethod {method arglist} { + variable compile + variable methodInfo + + set errRoot "Error in \"delegate method [list $method]...\"" + + # Next, parse the delegation options. + set component "" + set target "" + set exceptions {} + set pattern "" + set methodTail [lindex $method end] + + foreach {opt value} $arglist { + switch -exact $opt { + to { set component $value } + as { set target $value } + except { set exceptions $value } + using { set pattern $value } + default { + error "$errRoot, unknown delegation option \"$opt\"" + } + } + } + + if {"" == $component && "" == $pattern} { + error "$errRoot, missing \"to\"" + } + + if {"*" == $methodTail && "" != $target} { + error "$errRoot, cannot specify \"as\" with \"*\"" + } + + if {"*" != $methodTail && "" != $exceptions} { + error "$errRoot, can only specify \"except\" with \"*\"" + } + + if {"" != $pattern && "" != $target} { + error "$errRoot, cannot specify both \"as\" and \"using\"" + } + + foreach token [lrange $method 1 end-1] { + if {"*" == $token} { + error "$errRoot, \"*\" must be the last token." + } + } + + # NEXT, we delegate some methods + set compile(delegatesmethods) yes + + # NEXT, define the component. Allow typecomponents. + if {"" != $component} { + if {[lsearch -exact $compile(typecomponents) $component] == -1} { + Comp.DefineComponent $component $errRoot + } + } + + # NEXT, define the pattern. + if {"" == $pattern} { + if {"*" == $methodTail} { + set pattern "%c %m" + } elseif {"" != $target} { + set pattern "%c $target" + } else { + set pattern "%c %m" + } + } + + # Make sure the pattern is a valid list. + if {[catch {lindex $pattern 0} result]} { + error "$errRoot, the using pattern, \"$pattern\", is not a valid list" + } + + # NEXT, check the method name against previously defined + # methods. + Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot + + # NEXT, save the method info. + set methodInfo($method) [list 0 $pattern $component] + + if {[string equal $methodTail "*"]} { + Mappend compile(defs) { + set %TYPE%::Snit_info(exceptmethods) %EXCEPT% + } %EXCEPT% [list $exceptions] + } +} + +# Creates a delegated option, delegating it to a particular +# component and, optionally, to a particular option of that +# component. +# +# optionDef The option definition +# args definition arguments. + +proc ::snit::Comp.DelegatedOption {optionDef arglist} { + variable compile + + # First, get the three option names. + set option [lindex $optionDef 0] + set resourceName [lindex $optionDef 1] + set className [lindex $optionDef 2] + + set errRoot "Error in \"delegate option [list $optionDef]...\"" + + # Next, parse the delegation options. + set component "" + set target "" + set exceptions {} + + foreach {opt value} $arglist { + switch -exact $opt { + to { set component $value } + as { set target $value } + except { set exceptions $value } + default { + error "$errRoot, unknown delegation option \"$opt\"" + } + } + } + + if {"" == $component} { + error "$errRoot, missing \"to\"" + } + + if {"*" == $option && "" != $target} { + error "$errRoot, cannot specify \"as\" with \"delegate option *\"" + } + + if {"*" != $option && "" != $exceptions} { + error "$errRoot, can only specify \"except\" with \"delegate option *\"" + } + + # Next, validate the option name + + if {"*" != $option} { + if {![Comp.OptionNameIsValid $option]} { + error "$errRoot, badly named option \"$option\"" + } + } + + if {[Contains $option $compile(localoptions)]} { + error "$errRoot, \"$option\" has been defined locally" + } + + if {[Contains $option $compile(delegatedoptions)]} { + error "$errRoot, \"$option\" is multiply delegated" + } + + # NEXT, define the component + Comp.DefineComponent $component $errRoot + + # Next, define the target option, if not specified. + if {![string equal $option "*"] && + [string equal $target ""]} { + set target $option + } + + # NEXT, save the delegation data. + set compile(hasoptions) yes + + if {![string equal $option "*"]} { + lappend compile(delegatedoptions) $option + + # Next, compute the resource and class names, if they aren't + # already defined. + + if {"" == $resourceName} { + set resourceName [string range $option 1 end] + } + + if {"" == $className} { + set className [Capitalize $resourceName] + } + + Mappend compile(defs) { + set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0 + set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES% + set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS% + lappend %TYPE%::Snit_optionInfo(delegated) %OPTION% + set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%] + lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION% + } %OPTION% $option \ + %COMP% $component \ + %TARGET% $target \ + %RES% $resourceName \ + %CLASS% $className + } else { + Mappend compile(defs) { + set %TYPE%::Snit_optionInfo(starcomp) %COMP% + set %TYPE%::Snit_optionInfo(except) %EXCEPT% + } %COMP% $component %EXCEPT% [list $exceptions] + } +} + +# Exposes a component, effectively making the component's command an +# instance method. +# +# component The logical name of the delegate +# "as" sugar; if not "", must be "as" +# methodname The desired method name for the component's command, or "" + +proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} { + variable compile + + + # FIRST, define the component + Comp.DefineComponent $component + + # NEXT, define the method just as though it were in the type + # definition. + if {[string equal $methodname ""]} { + set methodname $component + } + + Comp.statement.method $methodname args [Expand { + if {[llength $args] == 0} { + return $%COMPONENT% + } + + if {[string equal $%COMPONENT% ""]} { + error "undefined component \"%COMPONENT%\"" + } + + + set cmd [linsert $args 0 $%COMPONENT%] + return [uplevel 1 $cmd] + } %COMPONENT% $component] +} + + + +#----------------------------------------------------------------------- +# Public commands + +# Compile a type definition, and return the results as a list of two +# items: the fully-qualified type name, and a script that will define +# the type when executed. +# +# which type, widget, or widgetadaptor +# type the type name +# body the type definition +proc ::snit::compile {which type body} { + return [Comp.Compile $which $type $body] +} + +proc ::snit::type {type body} { + return [Comp.Define [Comp.Compile type $type $body]] +} + +proc ::snit::widget {type body} { + return [Comp.Define [Comp.Compile widget $type $body]] +} + +proc ::snit::widgetadaptor {type body} { + return [Comp.Define [Comp.Compile widgetadaptor $type $body]] +} + +proc ::snit::typemethod {type method arglist body} { + # Make sure the type exists. + if {![info exists ${type}::Snit_info]} { + error "no such type: \"$type\"" + } + + upvar ${type}::Snit_info Snit_info + upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo + + # FIRST, check the typemethod name against previously defined + # typemethods. + Comp.CheckMethodName $method 0 ${type}::Snit_typemethodInfo \ + "Cannot define \"$method\"" + + # NEXT, check the arguments + CheckArgs "snit::typemethod $type $method" $arglist + + # Next, add magic reference to type. + set arglist [concat type $arglist] + + # Next, add typevariable declarations to body: + set body "$Snit_info(tvardecs)\n$body" + + # Next, define it. + if {[llength $method] == 1} { + set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""} + uplevel 1 [list proc ${type}::Snit_typemethod$method $arglist $body] + } else { + set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""} + set suffix [join $method _] + uplevel 1 [list proc ${type}::Snit_htypemethod$suffix $arglist $body] + } +} + +proc ::snit::method {type method arglist body} { + # Make sure the type exists. + if {![info exists ${type}::Snit_info]} { + error "no such type: \"$type\"" + } + + upvar ${type}::Snit_methodInfo Snit_methodInfo + upvar ${type}::Snit_info Snit_info + + # FIRST, check the method name against previously defined + # methods. + Comp.CheckMethodName $method 0 ${type}::Snit_methodInfo \ + "Cannot define \"$method\"" + + # NEXT, check the arguments + CheckArgs "snit::method $type $method" $arglist + + # Next, add magic references to type and self. + set arglist [concat type selfns win self $arglist] + + # Next, add variable declarations to body: + set body "$Snit_info(tvardecs)$Snit_info(ivardecs)\n$body" + + # Next, define it. + if {[llength $method] == 1} { + set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""} + uplevel 1 [list proc ${type}::Snit_method$method $arglist $body] + } else { + set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""} + + set suffix [join $method _] + uplevel 1 [list proc ${type}::Snit_hmethod$suffix $arglist $body] + } +} + +# Defines a proc within the compiler; this proc can call other +# type definition statements, and thus can be used for meta-programming. +proc ::snit::macro {name arglist body} { + variable compiler + variable reservedwords + + # FIRST, make sure the compiler is defined. + Comp.Init + + # NEXT, check the macro name against the reserved words + if {[lsearch -exact $reservedwords $name] != -1} { + error "invalid macro name \"$name\"" + } + + # NEXT, see if the name has a namespace; if it does, define the + # namespace. + set ns [namespace qualifiers $name] + + if {"" != $ns} { + $compiler eval "namespace eval $ns {}" + } + + # NEXT, define the macro + $compiler eval [list _proc $name $arglist $body] +} + +#----------------------------------------------------------------------- +# Utility Functions +# +# These are utility functions used while compiling Snit types. + +# Builds a template from a tagged list of text blocks, then substitutes +# all symbols in the mapTable, returning the expanded template. +proc ::snit::Expand {template args} { + return [string map $args $template] +} + +# Expands a template and appends it to a variable. +proc ::snit::Mappend {varname template args} { + upvar $varname myvar + + append myvar [string map $args $template] +} + +# Checks argument list against reserved args +proc ::snit::CheckArgs {which arglist} { + variable reservedArgs + + foreach name $reservedArgs { + if {[Contains $name $arglist]} { + error "$which's arglist may not contain \"$name\" explicitly" + } + } +} + +# Returns 1 if a value is in a list, and 0 otherwise. +proc ::snit::Contains {value list} { + if {[lsearch -exact $list $value] != -1} { + return 1 + } else { + return 0 + } +} + +# Capitalizes the first letter of a string. +proc ::snit::Capitalize {text} { + return [string toupper $text 0] +} + +# Converts an arbitrary white-space-delimited string into a list +# by splitting on white-space and deleting empty tokens. + +proc ::snit::Listify {str} { + set result {} + foreach token [split [string trim $str]] { + if {[string length $token] > 0} { + lappend result $token + } + } + + return $result +} + + +#======================================================================= +# Snit Runtime Library +# +# These are procs used by Snit types and widgets at runtime. + +#----------------------------------------------------------------------- +# Object Creation + +# Creates a new instance of the snit::type given its name and the args. +# +# type The snit::type +# name The instance name +# args Args to pass to the constructor + +proc ::snit::RT.type.typemethod.create {type name args} { + variable ${type}::Snit_info + variable ${type}::Snit_optionInfo + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; + # append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + + # NEXT, if %AUTO% appears in the name, generate a unique + # command name. Otherwise, ensure that the name isn't in use. + if {[string match "*%AUTO%*" $name]} { + set name [::snit::RT.UniqueName Snit_info(counter) $type $name] + } elseif {!$Snit_info(canreplace) && [llength [info commands $name]]} { + error "command \"$name\" already exists" + } + + # NEXT, create the instance's namespace. + set selfns \ + [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type] + namespace eval $selfns {} + + # NEXT, install the dispatcher + RT.MakeInstanceCommand $type $selfns $name + + # Initialize the options to their defaults. + upvar ${selfns}::options options + foreach opt $Snit_optionInfo(local) { + set options($opt) $Snit_optionInfo(default-$opt) + } + + # Initialize the instance vars to their defaults. + # selfns must be defined, as it is used implicitly. + ${type}::Snit_instanceVars $selfns + + # Execute the type's constructor. + set errcode [catch { + RT.ConstructInstance $type $selfns $name $args + } result] + + if {$errcode} { + global errorInfo + global errorCode + + set theInfo $errorInfo + set theCode $errorCode + ::snit::RT.DestroyObject $type $selfns $name + error "Error in constructor: $result" $theInfo $theCode + } + + # NEXT, return the object's name. + return $name +} + +# Creates a new instance of the snit::widget or snit::widgetadaptor +# given its name and the args. +# +# type The snit::widget or snit::widgetadaptor +# name The instance name +# args Args to pass to the constructor + +proc ::snit::RT.widget.typemethod.create {type name args} { + variable ${type}::Snit_info + variable ${type}::Snit_optionInfo + + # FIRST, if %AUTO% appears in the name, generate a unique + # command name. + if {[string match "*%AUTO%*" $name]} { + set name [::snit::RT.UniqueName Snit_info(counter) $type $name] + } + + # NEXT, create the instance's namespace. + set selfns \ + [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type] + namespace eval $selfns { } + + # NEXT, Initialize the widget's own options to their defaults. + upvar ${selfns}::options options + foreach opt $Snit_optionInfo(local) { + set options($opt) $Snit_optionInfo(default-$opt) + } + + # Initialize the instance vars to their defaults. + ${type}::Snit_instanceVars $selfns + + # NEXT, if this is a normal widget (not a widget adaptor) then create a + # frame as its hull. We set the frame's -class to the user's widgetclass, + # or, if none, search for -class in the args list, otherwise default to + # the basename of the $type with an initial upper case letter. + if {!$Snit_info(isWidgetAdaptor)} { + # FIRST, determine the class name + set wclass $Snit_info(widgetclass) + if {$Snit_info(widgetclass) eq ""} { + set idx [lsearch -exact $args -class] + if {$idx >= 0 && ($idx%2 == 0)} { + # -class exists and is in the -option position + set wclass [lindex $args [expr {$idx+1}]] + set args [lreplace $args $idx [expr {$idx+1}]] + } else { + set wclass [::snit::Capitalize [namespace tail $type]] + } + } + + # NEXT, create the widget + set self $name + package require Tk + ${type}::installhull using $Snit_info(hulltype) -class $wclass + + # NEXT, let's query the option database for our + # widget, now that we know that it exists. + foreach opt $Snit_optionInfo(local) { + set dbval [RT.OptionDbGet $type $name $opt] + + if {"" != $dbval} { + set options($opt) $dbval + } + } + } + + # Execute the type's constructor, and verify that it + # has a hull. + set errcode [catch { + RT.ConstructInstance $type $selfns $name $args + + ::snit::RT.Component $type $selfns hull + + # Prepare to call the object's destructor when the + # event is received. Use a Snit-specific bindtag + # so that the widget name's tag is unencumbered. + + bind Snit$type$name [::snit::Expand { + ::snit::RT.DestroyObject %TYPE% %NS% %W + } %TYPE% $type %NS% $selfns] + + # Insert the bindtag into the list of bindtags right + # after the widget name. + set taglist [bindtags $name] + set ndx [lsearch -exact $taglist $name] + incr ndx + bindtags $name [linsert $taglist $ndx Snit$type$name] + } result] + + if {$errcode} { + global errorInfo + global errorCode + + set theInfo $errorInfo + set theCode $errorCode + ::snit::RT.DestroyObject $type $selfns $name + error "Error in constructor: $result" $theInfo $theCode + } + + # NEXT, return the object's name. + return $name +} + + +# RT.MakeInstanceCommand type selfns instance +# +# type The object type +# selfns The instance namespace +# instance The instance name +# +# Creates the instance proc. + +proc ::snit::RT.MakeInstanceCommand {type selfns instance} { + variable ${type}::Snit_info + + # FIRST, remember the instance name. The Snit_instance variable + # allows the instance to figure out its current name given the + # instance namespace. + upvar ${selfns}::Snit_instance Snit_instance + set Snit_instance $instance + + # NEXT, qualify the proc name if it's a widget. + if {$Snit_info(isWidget)} { + set procname ::$instance + } else { + set procname $instance + } + + # NEXT, install the new proc + if {!$Snit_info(simpledispatch)} { + set instanceProc $::snit::nominalInstanceProc + } else { + set instanceProc $::snit::simpleInstanceProc + } + + proc $procname {method args} \ + [string map \ + [list %SELFNS% $selfns %WIN% $instance %TYPE% $type] \ + $instanceProc] + + # NEXT, add the trace. + trace add command $procname {rename delete} \ + [list ::snit::RT.InstanceTrace $type $selfns $instance] +} + +# This proc is called when the instance command is renamed. +# If op is delete, then new will always be "", so op is redundant. +# +# type The fully-qualified type name +# selfns The instance namespace +# win The original instance/tk window name. +# old old instance command name +# new new instance command name +# op rename or delete +# +# If the op is delete, we need to clean up the object; otherwise, +# we need to track the change. +# +# NOTE: In Tcl 8.4.2 there's a bug: errors in rename and delete +# traces aren't propagated correctly. Instead, they silently +# vanish. Add a catch to output any error message. + +proc ::snit::RT.InstanceTrace {type selfns win old new op} { + variable ${type}::Snit_info + + # Note to developers ... + # For Tcl 8.4.0, errors thrown in trace handlers vanish silently. + # Therefore we catch them here and create some output to help in + # debugging such problems. + + if {[catch { + # FIRST, clean up if necessary + if {"" == $new} { + if {$Snit_info(isWidget)} { + destroy $win + } else { + ::snit::RT.DestroyObject $type $selfns $win + } + } else { + # Otherwise, track the change. + variable ${selfns}::Snit_instance + set Snit_instance [uplevel 1 [list namespace which -command $new]] + + # Also, clear the instance caches, as many cached commands + # might be invalid. + RT.ClearInstanceCaches $selfns + } + } result]} { + global errorInfo + # Pop up the console on Windows wish, to enable stdout. + # This clobbers errorInfo on unix, so save it so we can print it. + set ei $errorInfo + catch {console show} + puts "Error in ::snit::RT.InstanceTrace $type $selfns $win $old $new $op:" + puts $ei + } +} + +# Calls the instance constructor and handles related housekeeping. +proc ::snit::RT.ConstructInstance {type selfns instance arglist} { + variable ${type}::Snit_optionInfo + variable ${selfns}::Snit_iinfo + + # Track whether we are constructed or not. + set Snit_iinfo(constructed) 0 + + # Call the user's constructor + eval [linsert $arglist 0 \ + ${type}::Snit_constructor $type $selfns $instance $instance] + + set Snit_iinfo(constructed) 1 + + # Validate the initial set of options (including defaults) + foreach option $Snit_optionInfo(local) { + set value [set ${selfns}::options($option)] + + if {"" != $Snit_optionInfo(typespec-$option)} { + if {[catch { + $Snit_optionInfo(typeobj-$option) validate $value + } result]} { + return -code error "invalid $option default: $result" + } + } + } + + # Unset the configure cache for all -readonly options. + # This ensures that the next time anyone tries to + # configure it, an error is thrown. + foreach opt $Snit_optionInfo(local) { + if {$Snit_optionInfo(readonly-$opt)} { + unset -nocomplain ${selfns}::Snit_configureCache($opt) + } + } + + return +} + +# Returns a unique command name. +# +# REQUIRE: type is a fully qualified name. +# REQUIRE: name contains "%AUTO%" +# PROMISE: the returned command name is unused. +proc ::snit::RT.UniqueName {countervar type name} { + upvar $countervar counter + while 1 { + # FIRST, bump the counter and define the %AUTO% instance name; + # then substitute it into the specified name. Wrap around at + # 2^31 - 2 to prevent overflow problems. + incr counter + if {$counter > 2147483646} { + set counter 0 + } + set auto "[namespace tail $type]$counter" + set candidate [Expand $name %AUTO% $auto] + if {![llength [info commands $candidate]]} { + return $candidate + } + } +} + +# Returns a unique instance namespace, fully qualified. +# +# countervar The name of a counter variable +# type The instance's type +# +# REQUIRE: type is fully qualified +# PROMISE: The returned namespace name is unused. + +proc ::snit::RT.UniqueInstanceNamespace {countervar type} { + upvar $countervar counter + while 1 { + # FIRST, bump the counter and define the namespace name. + # Then see if it already exists. Wrap around at + # 2^31 - 2 to prevent overflow problems. + incr counter + if {$counter > 2147483646} { + set counter 0 + } + set ins "${type}::Snit_inst${counter}" + if {![namespace exists $ins]} { + return $ins + } + } +} + +# Retrieves an option's value from the option database. +# Returns "" if no value is found. +proc ::snit::RT.OptionDbGet {type self opt} { + variable ${type}::Snit_optionInfo + + return [option get $self \ + $Snit_optionInfo(resource-$opt) \ + $Snit_optionInfo(class-$opt)] +} + +#----------------------------------------------------------------------- +# Object Destruction + +# Implements the standard "destroy" method +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name + +proc ::snit::RT.method.destroy {type selfns win self} { + variable ${selfns}::Snit_iinfo + + # Can't destroy the object if it isn't complete constructed. + if {!$Snit_iinfo(constructed)} { + return -code error "Called 'destroy' method in constructor" + } + + # Calls Snit_cleanup, which (among other things) calls the + # user's destructor. + ::snit::RT.DestroyObject $type $selfns $win +} + +# This is the function that really cleans up; it's automatically +# called when any instance is destroyed, e.g., by "$object destroy" +# for types, and by the event for widgets. +# +# type The fully-qualified type name. +# selfns The instance namespace +# win The original instance command name. + +proc ::snit::RT.DestroyObject {type selfns win} { + variable ${type}::Snit_info + + # If the variable Snit_instance doesn't exist then there's no + # instance command for this object -- it's most likely a + # widgetadaptor. Consequently, there are some things that + # we don't need to do. + if {[info exists ${selfns}::Snit_instance]} { + upvar ${selfns}::Snit_instance instance + + # First, remove the trace on the instance name, so that we + # don't call RT.DestroyObject recursively. + RT.RemoveInstanceTrace $type $selfns $win $instance + + # Next, call the user's destructor + ${type}::Snit_destructor $type $selfns $win $instance + + # Next, if this isn't a widget, delete the instance command. + # If it is a widget, get the hull component's name, and rename + # it back to the widget name + + # Next, delete the hull component's instance command, + # if there is one. + if {$Snit_info(isWidget)} { + set hullcmd [::snit::RT.Component $type $selfns hull] + + catch {rename $instance ""} + + # Clear the bind event + bind Snit$type$win "" + + if {[llength [info commands $hullcmd]]} { + # FIRST, rename the hull back to its original name. + # If the hull is itself a megawidget, it will have its + # own cleanup to do, and it might not do it properly + # if it doesn't have the right name. + rename $hullcmd ::$instance + + # NEXT, destroy it. + destroy $instance + } + } else { + catch {rename $instance ""} + } + } + + # Next, delete the instance's namespace. This kills any + # instance variables. + namespace delete $selfns + + return +} + +# Remove instance trace +# +# type The fully qualified type name +# selfns The instance namespace +# win The original instance name/Tk window name +# instance The current instance name + +proc ::snit::RT.RemoveInstanceTrace {type selfns win instance} { + variable ${type}::Snit_info + + if {$Snit_info(isWidget)} { + set procname ::$instance + } else { + set procname $instance + } + + # NEXT, remove any trace on this name + catch { + trace remove command $procname {rename delete} \ + [list ::snit::RT.InstanceTrace $type $selfns $win] + } +} + +#----------------------------------------------------------------------- +# Typecomponent Management and Method Caching + +# Typecomponent trace; used for write trace on typecomponent +# variables. Saves the new component object name, provided +# that certain conditions are met. Also clears the typemethod +# cache. + +proc ::snit::RT.TypecomponentTrace {type component n1 n2 op} { + upvar ${type}::Snit_info Snit_info + upvar ${type}::${component} cvar + upvar ${type}::Snit_typecomponents Snit_typecomponents + + # Save the new component value. + set Snit_typecomponents($component) $cvar + + # Clear the typemethod cache. + # TBD: can we unset just the elements related to + # this component? + unset -nocomplain -- ${type}::Snit_typemethodCache +} + +# Generates and caches the command for a typemethod. +# +# type The type +# method The name of the typemethod to call. +# +# The return value is one of the following lists: +# +# {} There's no such method. +# {1} The method has submethods; look again. +# {0 } Here's the command to execute. + +proc snit::RT.CacheTypemethodCommand {type method} { + upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo + upvar ${type}::Snit_typecomponents Snit_typecomponents + upvar ${type}::Snit_typemethodCache Snit_typemethodCache + upvar ${type}::Snit_info Snit_info + + # FIRST, get the pattern data and the typecomponent name. + set implicitCreate 0 + set instanceName "" + + set starredMethod [lreplace $method end end *] + set methodTail [lindex $method end] + + if {[info exists Snit_typemethodInfo($method)]} { + set key $method + } elseif {[info exists Snit_typemethodInfo($starredMethod)]} { + if {[lsearch -exact $Snit_info(excepttypemethods) $methodTail] == -1} { + set key $starredMethod + } else { + return [list ] + } + } elseif {[llength $method] > 1} { + return [list ] + } elseif {$Snit_info(hasinstances)} { + # Assume the unknown name is an instance name to create, unless + # this is a widget and the style of the name is wrong, or the + # name mimics a standard typemethod. + + if {[set ${type}::Snit_info(isWidget)] && + ![string match ".*" $method]} { + return [list ] + } + + # Without this check, the call "$type info" will redefine the + # standard "::info" command, with disastrous results. Since it's + # a likely thing to do if !-typeinfo, put in an explicit check. + if {"info" == $method || "destroy" == $method} { + return [list ] + } + + set implicitCreate 1 + set instanceName $method + set key create + set method create + } else { + return [list ] + } + + foreach {flag pattern compName} $Snit_typemethodInfo($key) {} + + if {$flag == 1} { + return [list 1] + } + + # NEXT, build the substitution list + set subList [list \ + %% % \ + %t $type \ + %M $method \ + %m [lindex $method end] \ + %j [join $method _]] + + if {"" != $compName} { + if {![info exists Snit_typecomponents($compName)]} { + error "$type delegates typemethod \"$method\" to undefined typecomponent \"$compName\"" + } + + lappend subList %c [list $Snit_typecomponents($compName)] + } + + set command {} + + foreach subpattern $pattern { + lappend command [string map $subList $subpattern] + } + + if {$implicitCreate} { + # In this case, $method is the name of the instance to + # create. Don't cache, as we usually won't do this one + # again. + lappend command $instanceName + } else { + set Snit_typemethodCache($method) [list 0 $command] + } + + return [list 0 $command] +} + + +#----------------------------------------------------------------------- +# Component Management and Method Caching + +# Retrieves the object name given the component name. +proc ::snit::RT.Component {type selfns name} { + variable ${selfns}::Snit_components + + if {[catch {set Snit_components($name)} result]} { + variable ${selfns}::Snit_instance + + error "component \"$name\" is undefined in $type $Snit_instance" + } + + return $result +} + +# Component trace; used for write trace on component instance +# variables. Saves the new component object name, provided +# that certain conditions are met. Also clears the method +# cache. + +proc ::snit::RT.ComponentTrace {type selfns component n1 n2 op} { + upvar ${type}::Snit_info Snit_info + upvar ${selfns}::${component} cvar + upvar ${selfns}::Snit_components Snit_components + + # If they try to redefine the hull component after + # it's been defined, that's an error--but only if + # this is a widget or widget adaptor. + if {"hull" == $component && + $Snit_info(isWidget) && + [info exists Snit_components($component)]} { + set cvar $Snit_components($component) + error "The hull component cannot be redefined" + } + + # Save the new component value. + set Snit_components($component) $cvar + + # Clear the instance caches. + # TBD: can we unset just the elements related to + # this component? + RT.ClearInstanceCaches $selfns +} + +# Generates and caches the command for a method. +# +# type: The instance's type +# selfns: The instance's private namespace +# win: The instance's original name (a Tk widget name, for +# snit::widgets. +# self: The instance's current name. +# method: The name of the method to call. +# +# The return value is one of the following lists: +# +# {} There's no such method. +# {1} The method has submethods; look again. +# {0 } Here's the command to execute. + +proc ::snit::RT.CacheMethodCommand {type selfns win self method} { + variable ${type}::Snit_info + variable ${type}::Snit_methodInfo + variable ${type}::Snit_typecomponents + variable ${selfns}::Snit_components + variable ${selfns}::Snit_methodCache + + # FIRST, get the pattern data and the component name. + set starredMethod [lreplace $method end end *] + set methodTail [lindex $method end] + + if {[info exists Snit_methodInfo($method)]} { + set key $method + } elseif {[info exists Snit_methodInfo($starredMethod)] && + [lsearch -exact $Snit_info(exceptmethods) $methodTail] == -1} { + set key $starredMethod + } else { + return [list ] + } + + foreach {flag pattern compName} $Snit_methodInfo($key) {} + + if {$flag == 1} { + return [list 1] + } + + # NEXT, build the substitution list + set subList [list \ + %% % \ + %t $type \ + %M $method \ + %m [lindex $method end] \ + %j [join $method _] \ + %n [list $selfns] \ + %w [list $win] \ + %s [list $self]] + + if {"" != $compName} { + if {[info exists Snit_components($compName)]} { + set compCmd $Snit_components($compName) + } elseif {[info exists Snit_typecomponents($compName)]} { + set compCmd $Snit_typecomponents($compName) + } else { + error "$type $self delegates method \"$method\" to undefined component \"$compName\"" + } + + lappend subList %c [list $compCmd] + } + + # Note: The cached command will executed faster if it's + # already a list. + set command {} + + foreach subpattern $pattern { + lappend command [string map $subList $subpattern] + } + + set commandRec [list 0 $command] + + set Snit_methodCache($method) $commandRec + + return $commandRec +} + + +# Looks up a method's command. +# +# type: The instance's type +# selfns: The instance's private namespace +# win: The instance's original name (a Tk widget name, for +# snit::widgets. +# self: The instance's current name. +# method: The name of the method to call. +# errPrefix: Prefix for any error method +proc ::snit::RT.LookupMethodCommand {type selfns win self method errPrefix} { + set commandRec [snit::RT.CacheMethodCommand \ + $type $selfns $win $self \ + $method] + + + if {[llength $commandRec] == 0} { + return -code error \ + "$errPrefix, \"$self $method\" is not defined" + } elseif {[lindex $commandRec 0] == 1} { + return -code error \ + "$errPrefix, wrong number args: should be \"$self\" $method method args" + } + + return [lindex $commandRec 1] +} + + +# Clears all instance command caches +proc ::snit::RT.ClearInstanceCaches {selfns} { + unset -nocomplain -- ${selfns}::Snit_methodCache + unset -nocomplain -- ${selfns}::Snit_cgetCache + unset -nocomplain -- ${selfns}::Snit_configureCache + unset -nocomplain -- ${selfns}::Snit_validateCache +} + + +#----------------------------------------------------------------------- +# Component Installation + +# Implements %TYPE%::installhull. The variables self and selfns +# must be defined in the caller's context. +# +# Installs the named widget as the hull of a +# widgetadaptor. Once the widget is hijacked, its new name +# is assigned to the hull component. + +proc ::snit::RT.installhull {type {using "using"} {widgetType ""} args} { + variable ${type}::Snit_info + variable ${type}::Snit_optionInfo + upvar self self + upvar selfns selfns + upvar ${selfns}::hull hull + upvar ${selfns}::options options + + # FIRST, make sure we can do it. + if {!$Snit_info(isWidget)} { + error "installhull is valid only for snit::widgetadaptors" + } + + if {[info exists ${selfns}::Snit_instance]} { + error "hull already installed for $type $self" + } + + # NEXT, has it been created yet? If not, create it using + # the specified arguments. + if {"using" == $using} { + # FIRST, create the widget + set cmd [linsert $args 0 $widgetType $self] + set obj [uplevel 1 $cmd] + + # NEXT, for each option explicitly delegated to the hull + # that doesn't appear in the usedOpts list, get the + # option database value and apply it--provided that the + # real option name and the target option name are different. + # (If they are the same, then the option database was + # already queried as part of the normal widget creation.) + # + # Also, we don't need to worry about implicitly delegated + # options, as the option and target option names must be + # the same. + if {[info exists Snit_optionInfo(delegated-hull)]} { + + # FIRST, extract all option names from args + set usedOpts {} + set ndx [lsearch -glob $args "-*"] + foreach {opt val} [lrange $args $ndx end] { + lappend usedOpts $opt + } + + foreach opt $Snit_optionInfo(delegated-hull) { + set target [lindex $Snit_optionInfo(target-$opt) 1] + + if {"$target" == $opt} { + continue + } + + set result [lsearch -exact $usedOpts $target] + + if {$result != -1} { + continue + } + + set dbval [RT.OptionDbGet $type $self $opt] + $obj configure $target $dbval + } + } + } else { + set obj $using + + if {![string equal $obj $self]} { + error \ + "hull name mismatch: \"$obj\" != \"$self\"" + } + } + + # NEXT, get the local option defaults. + foreach opt $Snit_optionInfo(local) { + set dbval [RT.OptionDbGet $type $self $opt] + + if {"" != $dbval} { + set options($opt) $dbval + } + } + + + # NEXT, do the magic + set i 0 + while 1 { + incr i + set newName "::hull${i}$self" + if {![llength [info commands $newName]]} { + break + } + } + + rename ::$self $newName + RT.MakeInstanceCommand $type $selfns $self + + # Note: this relies on RT.ComponentTrace to do the dirty work. + set hull $newName + + return +} + +# Implements %TYPE%::install. +# +# Creates a widget and installs it as the named component. +# It expects self and selfns to be defined in the caller's context. + +proc ::snit::RT.install {type compName "using" widgetType winPath args} { + variable ${type}::Snit_optionInfo + variable ${type}::Snit_info + upvar self self + upvar selfns selfns + upvar ${selfns}::$compName comp + upvar ${selfns}::hull hull + + # We do the magic option database stuff only if $self is + # a widget. + if {$Snit_info(isWidget)} { + if {"" == $hull} { + error "tried to install \"$compName\" before the hull exists" + } + + # FIRST, query the option database and save the results + # into args. Insert them before the first option in the + # list, in case there are any non-standard parameters. + # + # Note: there might not be any delegated options; if so, + # don't bother. + + if {[info exists Snit_optionInfo(delegated-$compName)]} { + set ndx [lsearch -glob $args "-*"] + + foreach opt $Snit_optionInfo(delegated-$compName) { + set dbval [RT.OptionDbGet $type $self $opt] + + if {"" != $dbval} { + set target [lindex $Snit_optionInfo(target-$opt) 1] + set args [linsert $args $ndx $target $dbval] + } + } + } + } + + # NEXT, create the component and save it. + set cmd [concat [list $widgetType $winPath] $args] + set comp [uplevel 1 $cmd] + + # NEXT, handle the option database for "delegate option *", + # in widgets only. + if {$Snit_info(isWidget) && [string equal $Snit_optionInfo(starcomp) $compName]} { + # FIRST, get the list of option specs from the widget. + # If configure doesn't work, skip it. + if {[catch {$comp configure} specs]} { + return + } + + # NEXT, get the set of explicitly used options from args + set usedOpts {} + set ndx [lsearch -glob $args "-*"] + foreach {opt val} [lrange $args $ndx end] { + lappend usedOpts $opt + } + + # NEXT, "delegate option *" matches all options defined + # by this widget that aren't defined by the widget as a whole, + # and that aren't excepted. Plus, we skip usedOpts. So build + # a list of the options it can't match. + set skiplist [concat \ + $usedOpts \ + $Snit_optionInfo(except) \ + $Snit_optionInfo(local) \ + $Snit_optionInfo(delegated)] + + # NEXT, loop over all of the component's options, and set + # any not in the skip list for which there is an option + # database value. + foreach spec $specs { + # Skip aliases + if {[llength $spec] != 5} { + continue + } + + set opt [lindex $spec 0] + + if {[lsearch -exact $skiplist $opt] != -1} { + continue + } + + set res [lindex $spec 1] + set cls [lindex $spec 2] + + set dbvalue [option get $self $res $cls] + + if {"" != $dbvalue} { + $comp configure $opt $dbvalue + } + } + } + + return +} + + +#----------------------------------------------------------------------- +# Method/Variable Name Qualification + +# Implements %TYPE%::variable. Requires selfns. +proc ::snit::RT.variable {varname} { + upvar selfns selfns + + if {![string match "::*" $varname]} { + uplevel 1 [list upvar 1 ${selfns}::$varname $varname] + } else { + # varname is fully qualified; let the standard + # "variable" command handle it. + uplevel 1 [list ::variable $varname] + } +} + +# Fully qualifies a typevariable name. +# +# This is used to implement the mytypevar command. + +proc ::snit::RT.mytypevar {type name} { + return ${type}::$name +} + +# Fully qualifies an instance variable name. +# +# This is used to implement the myvar command. +proc ::snit::RT.myvar {name} { + upvar selfns selfns + return ${selfns}::$name +} + +# Use this like "list" to convert a proc call into a command +# string to pass to another object (e.g., as a -command). +# Qualifies the proc name properly. +# +# This is used to implement the "myproc" command. + +proc ::snit::RT.myproc {type procname args} { + set procname "${type}::$procname" + return [linsert $args 0 $procname] +} + +# DEPRECATED +proc ::snit::RT.codename {type name} { + return "${type}::$name" +} + +# Use this like "list" to convert a typemethod call into a command +# string to pass to another object (e.g., as a -command). +# Inserts the type command at the beginning. +# +# This is used to implement the "mytypemethod" command. + +proc ::snit::RT.mytypemethod {type args} { + return [linsert $args 0 $type] +} + +# Use this like "list" to convert a method call into a command +# string to pass to another object (e.g., as a -command). +# Inserts the code at the beginning to call the right object, even if +# the object's name has changed. Requires that selfns be defined +# in the calling context, eg. can only be called in instance +# code. +# +# This is used to implement the "mymethod" command. + +proc ::snit::RT.mymethod {args} { + upvar selfns selfns + return [linsert $args 0 ::snit::RT.CallInstance ${selfns}] +} + +# Calls an instance method for an object given its +# instance namespace and remaining arguments (the first of which +# will be the method name. +# +# selfns The instance namespace +# args The arguments +# +# Uses the selfns to determine $self, and calls the method +# in the normal way. +# +# This is used to implement the "mymethod" command. + +proc ::snit::RT.CallInstance {selfns args} { + upvar ${selfns}::Snit_instance self + + set retval [catch {uplevel 1 [linsert $args 0 $self]} result] + + if {$retval} { + if {$retval == 1} { + global errorInfo + global errorCode + return -code error -errorinfo $errorInfo \ + -errorcode $errorCode $result + } else { + return -code $retval $result + } + } + + return $result +} + +# Looks for the named option in the named variable. If found, +# it and its value are removed from the list, and the value +# is returned. Otherwise, the default value is returned. +# If the option is undelegated, it's own default value will be +# used if none is specified. +# +# Implements the "from" command. + +proc ::snit::RT.from {type argvName option {defvalue ""}} { + variable ${type}::Snit_optionInfo + upvar $argvName argv + + set ioption [lsearch -exact $argv $option] + + if {$ioption == -1} { + if {"" == $defvalue && + [info exists Snit_optionInfo(default-$option)]} { + return $Snit_optionInfo(default-$option) + } else { + return $defvalue + } + } + + set ivalue [expr {$ioption + 1}] + set value [lindex $argv $ivalue] + + set argv [lreplace $argv $ioption $ivalue] + + return $value +} + +#----------------------------------------------------------------------- +# Type Destruction + +# Implements the standard "destroy" typemethod: +# Destroys a type completely. +# +# type The snit type + +proc ::snit::RT.typemethod.destroy {type} { + variable ${type}::Snit_info + + # FIRST, destroy all instances + foreach selfns [namespace children $type "${type}::Snit_inst*"] { + if {![namespace exists $selfns]} { + continue + } + upvar ${selfns}::Snit_instance obj + + if {$Snit_info(isWidget)} { + destroy $obj + } else { + if {[llength [info commands $obj]]} { + $obj destroy + } + } + } + + # NEXT, destroy the type's data. + namespace delete $type + + # NEXT, get rid of the type command. + rename $type "" +} + + + +#----------------------------------------------------------------------- +# Option Handling + +# Implements the standard "cget" method +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# option The name of the option + +proc ::snit::RT.method.cget {type selfns win self option} { + if {[catch {set ${selfns}::Snit_cgetCache($option)} command]} { + set command [snit::RT.CacheCgetCommand $type $selfns $win $self $option] + + if {[llength $command] == 0} { + return -code error "unknown option \"$option\"" + } + } + + uplevel 1 $command +} + +# Retrieves and caches the command that implements "cget" for the +# specified option. +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# option The name of the option + +proc ::snit::RT.CacheCgetCommand {type selfns win self option} { + variable ${type}::Snit_optionInfo + variable ${selfns}::Snit_cgetCache + + if {[info exists Snit_optionInfo(islocal-$option)]} { + # We know the item; it's either local, or explicitly delegated. + if {$Snit_optionInfo(islocal-$option)} { + # It's a local option. If it has a cget method defined, + # use it; otherwise just return the value. + + if {"" == $Snit_optionInfo(cget-$option)} { + set command [list set ${selfns}::options($option)] + } else { + set command [snit::RT.LookupMethodCommand \ + $type $selfns $win $self \ + $Snit_optionInfo(cget-$option) \ + "can't cget $option"] + + lappend command $option + } + + set Snit_cgetCache($option) $command + return $command + } + + # Explicitly delegated option; get target + set comp [lindex $Snit_optionInfo(target-$option) 0] + set target [lindex $Snit_optionInfo(target-$option) 1] + } elseif {"" != $Snit_optionInfo(starcomp) && + [lsearch -exact $Snit_optionInfo(except) $option] == -1} { + # Unknown option, but unknowns are delegated; get target. + set comp $Snit_optionInfo(starcomp) + set target $option + } else { + return "" + } + + # Get the component's object. + set obj [RT.Component $type $selfns $comp] + + set command [list $obj cget $target] + set Snit_cgetCache($option) $command + + return $command +} + +# Implements the standard "configurelist" method +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# optionlist A list of options and their values. + +proc ::snit::RT.method.configurelist {type selfns win self optionlist} { + variable ${type}::Snit_optionInfo + + foreach {option value} $optionlist { + # FIRST, get the configure command, caching it if need be. + if {[catch {set ${selfns}::Snit_configureCache($option)} command]} { + set command [snit::RT.CacheConfigureCommand \ + $type $selfns $win $self $option] + + if {[llength $command] == 0} { + return -code error "unknown option \"$option\"" + } + } + + # NEXT, if we have a type-validation object, use it. + # TBD: Should test (islocal-$option) here, but islocal + # isn't defined for implicitly delegated options. + if {[info exists Snit_optionInfo(typeobj-$option)] + && "" != $Snit_optionInfo(typeobj-$option)} { + if {[catch { + $Snit_optionInfo(typeobj-$option) validate $value + } result]} { + return -code error "invalid $option value: $result" + } + } + + # NEXT, the caching the configure command also cached the + # validate command, if any. If we have one, run it. + set valcommand [set ${selfns}::Snit_validateCache($option)] + + if {[llength $valcommand]} { + lappend valcommand $value + uplevel 1 $valcommand + } + + # NEXT, configure the option with the value. + lappend command $value + uplevel 1 $command + } + + return +} + +# Retrieves and caches the command that stores the named option. +# Also stores the command that validates the name option if any; +# If none, the validate command is "", so that the cache is always +# populated. +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# option An option name + +proc ::snit::RT.CacheConfigureCommand {type selfns win self option} { + variable ${type}::Snit_optionInfo + variable ${selfns}::Snit_configureCache + variable ${selfns}::Snit_validateCache + + if {[info exist Snit_optionInfo(islocal-$option)]} { + # We know the item; it's either local, or explicitly delegated. + + if {$Snit_optionInfo(islocal-$option)} { + # It's a local option. + + # If it's readonly, it throws an error if we're already + # constructed. + if {$Snit_optionInfo(readonly-$option)} { + if {[set ${selfns}::Snit_iinfo(constructed)]} { + error "option $option can only be set at instance creation" + } + } + + # If it has a validate method, cache that for later. + if {"" != $Snit_optionInfo(validate-$option)} { + set command [snit::RT.LookupMethodCommand \ + $type $selfns $win $self \ + $Snit_optionInfo(validate-$option) \ + "can't validate $option"] + + lappend command $option + set Snit_validateCache($option) $command + } else { + set Snit_validateCache($option) "" + } + + # If it has a configure method defined, + # cache it; otherwise, just set the value. + + if {"" == $Snit_optionInfo(configure-$option)} { + set command [list set ${selfns}::options($option)] + } else { + set command [snit::RT.LookupMethodCommand \ + $type $selfns $win $self \ + $Snit_optionInfo(configure-$option) \ + "can't configure $option"] + + lappend command $option + } + + set Snit_configureCache($option) $command + return $command + } + + # Delegated option: get target. + set comp [lindex $Snit_optionInfo(target-$option) 0] + set target [lindex $Snit_optionInfo(target-$option) 1] + } elseif {$Snit_optionInfo(starcomp) != "" && + [lsearch -exact $Snit_optionInfo(except) $option] == -1} { + # Unknown option, but unknowns are delegated. + set comp $Snit_optionInfo(starcomp) + set target $option + } else { + return "" + } + + # There is no validate command in this case; save an empty string. + set Snit_validateCache($option) "" + + # Get the component's object + set obj [RT.Component $type $selfns $comp] + + set command [list $obj configure $target] + set Snit_configureCache($option) $command + + return $command +} + +# Implements the standard "configure" method +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# args A list of options and their values, possibly empty. + +proc ::snit::RT.method.configure {type selfns win self args} { + # If two or more arguments, set values as usual. + if {[llength $args] >= 2} { + ::snit::RT.method.configurelist $type $selfns $win $self $args + return + } + + # If zero arguments, acquire data for each known option + # and return the list + if {[llength $args] == 0} { + set result {} + foreach opt [RT.method.info.options $type $selfns $win $self] { + # Refactor this, so that we don't need to call via $self. + lappend result [RT.GetOptionDbSpec \ + $type $selfns $win $self $opt] + } + + return $result + } + + # They want it for just one. + set opt [lindex $args 0] + + return [RT.GetOptionDbSpec $type $selfns $win $self $opt] +} + + +# Retrieves the option database spec for a single option. +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# option The name of an option +# +# TBD: This is a bad name. What it's returning is the +# result of the configure query. + +proc ::snit::RT.GetOptionDbSpec {type selfns win self opt} { + variable ${type}::Snit_optionInfo + + upvar ${selfns}::Snit_components Snit_components + upvar ${selfns}::options options + + if {[info exists options($opt)]} { + # This is a locally-defined option. Just build the + # list and return it. + set res $Snit_optionInfo(resource-$opt) + set cls $Snit_optionInfo(class-$opt) + set def $Snit_optionInfo(default-$opt) + + return [list $opt $res $cls $def \ + [RT.method.cget $type $selfns $win $self $opt]] + } elseif {[info exists Snit_optionInfo(target-$opt)]} { + # This is an explicitly delegated option. The only + # thing we don't have is the default. + set res $Snit_optionInfo(resource-$opt) + set cls $Snit_optionInfo(class-$opt) + + # Get the default + set logicalName [lindex $Snit_optionInfo(target-$opt) 0] + set comp $Snit_components($logicalName) + set target [lindex $Snit_optionInfo(target-$opt) 1] + + if {[catch {$comp configure $target} result]} { + set defValue {} + } else { + set defValue [lindex $result 3] + } + + return [list $opt $res $cls $defValue [$self cget $opt]] + } elseif {"" != $Snit_optionInfo(starcomp) && + [lsearch -exact $Snit_optionInfo(except) $opt] == -1} { + set logicalName $Snit_optionInfo(starcomp) + set target $opt + set comp $Snit_components($logicalName) + + if {[catch {set value [$comp cget $target]} result]} { + error "unknown option \"$opt\"" + } + + if {![catch {$comp configure $target} result]} { + # Replace the delegated option name with the local name. + return [::snit::Expand $result $target $opt] + } + + # configure didn't work; return simple form. + return [list $opt "" "" "" $value] + } else { + error "unknown option \"$opt\"" + } +} + +#----------------------------------------------------------------------- +# Type Introspection + +# Implements the standard "info" typemethod. +# +# type The snit type +# command The info subcommand +# args All other arguments. + +proc ::snit::RT.typemethod.info {type command args} { + global errorInfo + global errorCode + + switch -exact $command { + args - + body - + default - + typevars - + typemethods - + instances { + # TBD: it should be possible to delete this error + # handling. + set errflag [catch { + uplevel 1 [linsert $args 0 \ + ::snit::RT.typemethod.info.$command $type] + } result] + + if {$errflag} { + return -code error -errorinfo $errorInfo \ + -errorcode $errorCode $result + } else { + return $result + } + } + default { + error "\"$type info $command\" is not defined" + } + } +} + + +# Returns a list of the type's typevariables whose names match a +# pattern, excluding Snit internal variables. +# +# type A Snit type +# pattern Optional. The glob pattern to match. Defaults +# to *. + +proc ::snit::RT.typemethod.info.typevars {type {pattern *}} { + set result {} + foreach name [info vars "${type}::$pattern"] { + set tail [namespace tail $name] + if {![string match "Snit_*" $tail]} { + lappend result $name + } + } + + return $result +} + +# Returns a list of the type's methods whose names match a +# pattern. If "delegate typemethod *" is used, the list may +# not be complete. +# +# type A Snit type +# pattern Optional. The glob pattern to match. Defaults +# to *. + +proc ::snit::RT.typemethod.info.typemethods {type {pattern *}} { + variable ${type}::Snit_typemethodInfo + variable ${type}::Snit_typemethodCache + + # FIRST, get the explicit names, skipping prefixes. + set result {} + + foreach name [array names Snit_typemethodInfo $pattern] { + if {[lindex $Snit_typemethodInfo($name) 0] != 1} { + lappend result $name + } + } + + # NEXT, add any from the cache that aren't explicit. + if {[info exists Snit_typemethodInfo(*)]} { + # First, remove "*" from the list. + set ndx [lsearch -exact $result "*"] + if {$ndx != -1} { + set result [lreplace $result $ndx $ndx] + } + + foreach name [array names Snit_typemethodCache $pattern] { + if {[lsearch -exact $result $name] == -1} { + lappend result $name + } + } + } + + return $result +} + +# $type info args +# +# Returns a method's list of arguments. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.typemethod.info.args {type method} { + upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_typemethodInfo + + if {![info exists Snit_typemethodInfo($method)]} { + return -code error "Unknown typemethod \"$method\"" + } + foreach {flag cmd component} $Snit_typemethodInfo($method) break + if {$flag} { + return -code error "Unknown typemethod \"$method\"" + } + if {$component != ""} { + return -code error "Delegated typemethod \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type] + set theproc [lindex [string map $map $cmd] 0] + return [lrange [::info args $theproc] 1 end] +} + +# $type info body +# +# Returns a method's body. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.typemethod.info.body {type method} { + upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_typemethodInfo + + if {![info exists Snit_typemethodInfo($method)]} { + return -code error "Unknown typemethod \"$method\"" + } + foreach {flag cmd component} $Snit_typemethodInfo($method) break + if {$flag} { + return -code error "Unknown typemethod \"$method\"" + } + if {$component != ""} { + return -code error "Delegated typemethod \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type] + set theproc [lindex [string map $map $cmd] 0] + return [RT.body [::info body $theproc]] +} + +# $type info default +# +# Returns a method's list of arguments. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.typemethod.info.default {type method aname dvar} { + upvar 1 $dvar def + upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_methodInfo + + if {![info exists Snit_typemethodInfo($method)]} { + return -code error "Unknown typemethod \"$method\"" + } + foreach {flag cmd component} $Snit_typemethodInfo($method) break + if {$flag} { + return -code error "Unknown typemethod \"$method\"" + } + if {$component != ""} { + return -code error "Delegated typemethod \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type] + set theproc [lindex [string map $map $cmd] 0] + return [::info default $theproc $aname def] +} + +# Returns a list of the type's instances whose names match +# a pattern. +# +# type A Snit type +# pattern Optional. The glob pattern to match +# Defaults to * +# +# REQUIRE: type is fully qualified. + +proc ::snit::RT.typemethod.info.instances {type {pattern *}} { + set result {} + + foreach selfns [namespace children $type "${type}::Snit_inst*"] { + upvar ${selfns}::Snit_instance instance + + if {[string match $pattern $instance]} { + lappend result $instance + } + } + + return $result +} + +#----------------------------------------------------------------------- +# Instance Introspection + +# Implements the standard "info" method. +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# command The info subcommand +# args All other arguments. + +proc ::snit::RT.method.info {type selfns win self command args} { + switch -exact $command { + args - + body - + default - + type - + vars - + options - + methods - + typevars - + typemethods { + set errflag [catch { + uplevel 1 [linsert $args 0 ::snit::RT.method.info.$command \ + $type $selfns $win $self] + } result] + + if {$errflag} { + global errorInfo + return -code error -errorinfo $errorInfo $result + } else { + return $result + } + } + default { + # error "\"$self info $command\" is not defined" + return -code error "\"$self info $command\" is not defined" + } + } +} + +# $self info type +# +# Returns the instance's type +proc ::snit::RT.method.info.type {type selfns win self} { + return $type +} + +# $self info typevars +# +# Returns the instance's type's typevariables +proc ::snit::RT.method.info.typevars {type selfns win self {pattern *}} { + return [RT.typemethod.info.typevars $type $pattern] +} + +# $self info typemethods +# +# Returns the instance's type's typemethods +proc ::snit::RT.method.info.typemethods {type selfns win self {pattern *}} { + return [RT.typemethod.info.typemethods $type $pattern] +} + +# Returns a list of the instance's methods whose names match a +# pattern. If "delegate method *" is used, the list may +# not be complete. +# +# type A Snit type +# selfns The instance namespace +# win The original instance name +# self The current instance name +# pattern Optional. The glob pattern to match. Defaults +# to *. + +proc ::snit::RT.method.info.methods {type selfns win self {pattern *}} { + variable ${type}::Snit_methodInfo + variable ${selfns}::Snit_methodCache + + # FIRST, get the explicit names, skipping prefixes. + set result {} + + foreach name [array names Snit_methodInfo $pattern] { + if {[lindex $Snit_methodInfo($name) 0] != 1} { + lappend result $name + } + } + + # NEXT, add any from the cache that aren't explicit. + if {[info exists Snit_methodInfo(*)]} { + # First, remove "*" from the list. + set ndx [lsearch -exact $result "*"] + if {$ndx != -1} { + set result [lreplace $result $ndx $ndx] + } + + foreach name [array names Snit_methodCache $pattern] { + if {[lsearch -exact $result $name] == -1} { + lappend result $name + } + } + } + + return $result +} + +# $self info args +# +# Returns a method's list of arguments. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.method.info.args {type selfns win self method} { + + upvar ${type}::Snit_methodInfo Snit_methodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_methodInfo + + if {![info exists Snit_methodInfo($method)]} { + return -code error "Unknown method \"$method\"" + } + foreach {flag cmd component} $Snit_methodInfo($method) break + if {$flag} { + return -code error "Unknown method \"$method\"" + } + if {$component != ""} { + return -code error "Delegated method \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] + set theproc [lindex [string map $map $cmd] 0] + return [lrange [::info args $theproc] 4 end] +} + +# $self info body +# +# Returns a method's body. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.method.info.body {type selfns win self method} { + + upvar ${type}::Snit_methodInfo Snit_methodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_methodInfo + + if {![info exists Snit_methodInfo($method)]} { + return -code error "Unknown method \"$method\"" + } + foreach {flag cmd component} $Snit_methodInfo($method) break + if {$flag} { + return -code error "Unknown method \"$method\"" + } + if {$component != ""} { + return -code error "Delegated method \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] + set theproc [lindex [string map $map $cmd] 0] + return [RT.body [::info body $theproc]] +} + +# $self info default +# +# Returns a method's list of arguments. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.method.info.default {type selfns win self method aname dvar} { + upvar 1 $dvar def + upvar ${type}::Snit_methodInfo Snit_methodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + if {![info exists Snit_methodInfo($method)]} { + return -code error "Unknown method \"$method\"" + } + foreach {flag cmd component} $Snit_methodInfo($method) break + if {$flag} { + return -code error "Unknown method \"$method\"" + } + if {$component != ""} { + return -code error "Delegated method \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] + set theproc [lindex [string map $map $cmd] 0] + return [::info default $theproc $aname def] +} + +# $self info vars +# +# Returns the instance's instance variables +proc ::snit::RT.method.info.vars {type selfns win self {pattern *}} { + set result {} + foreach name [info vars "${selfns}::$pattern"] { + set tail [namespace tail $name] + if {![string match "Snit_*" $tail]} { + lappend result $name + } + } + + return $result +} + +# $self info options +# +# Returns a list of the names of the instance's options +proc ::snit::RT.method.info.options {type selfns win self {pattern *}} { + variable ${type}::Snit_optionInfo + + # First, get the local and explicitly delegated options + set result [concat $Snit_optionInfo(local) $Snit_optionInfo(delegated)] + + # If "configure" works as for Tk widgets, add the resulting + # options to the list. Skip excepted options + if {"" != $Snit_optionInfo(starcomp)} { + upvar ${selfns}::Snit_components Snit_components + set logicalName $Snit_optionInfo(starcomp) + set comp $Snit_components($logicalName) + + if {![catch {$comp configure} records]} { + foreach record $records { + set opt [lindex $record 0] + if {[lsearch -exact $result $opt] == -1 && + [lsearch -exact $Snit_optionInfo(except) $opt] == -1} { + lappend result $opt + } + } + } + } + + # Next, apply the pattern + set names {} + + foreach name $result { + if {[string match $pattern $name]} { + lappend names $name + } + } + + return $names +} + +proc ::snit::RT.body {body} { + regsub -all ".*# END snit method prolog\n" $body {} body + return $body +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/main2.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/main2.tcl new file mode 100644 index 00000000..24563938 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/main2.tcl @@ -0,0 +1,3888 @@ +#----------------------------------------------------------------------- +# TITLE: +# main2.tcl +# +# AUTHOR: +# Will Duquette +# +# DESCRIPTION: +# Snit's Not Incr Tcl, a simple object system in Pure Tcl. +# +# Snit 2.x Compiler and Run-Time Library +# +# Copyright (C) 2003-2006 by William H. Duquette +# This code is licensed as described in license.txt. +# +#----------------------------------------------------------------------- + +#----------------------------------------------------------------------- +# Namespace + +namespace eval ::snit:: { + namespace export \ + compile type widget widgetadaptor typemethod method macro +} + +#----------------------------------------------------------------------- +# Some Snit variables + +namespace eval ::snit:: { + variable reservedArgs {type selfns win self} + + # Widget classes which can be hulls (must have -class) + variable hulltypes { + toplevel tk::toplevel + frame tk::frame ttk::frame + labelframe tk::labelframe ttk::labelframe + } +} + +#----------------------------------------------------------------------- +# Snit Type Implementation template + +namespace eval ::snit:: { + # Template type definition: All internal and user-visible Snit + # implementation code. + # + # The following placeholders will automatically be replaced with + # the client's code, in two passes: + # + # First pass: + # %COMPILEDDEFS% The compiled type definition. + # + # Second pass: + # %TYPE% The fully qualified type name. + # %IVARDECS% Instance variable declarations + # %TVARDECS% Type variable declarations + # %TCONSTBODY% Type constructor body + # %INSTANCEVARS% The compiled instance variable initialization code. + # %TYPEVARS% The compiled type variable initialization code. + + # This is the overall type template. + variable typeTemplate + + # This is the normal type proc + variable nominalTypeProc + + # This is the "-hastypemethods no" type proc + variable simpleTypeProc +} + +set ::snit::typeTemplate { + + #------------------------------------------------------------------- + # The type's namespace definition and the user's type variables + + namespace eval %TYPE% {%TYPEVARS% + } + + #---------------------------------------------------------------- + # Commands for use in methods, typemethods, etc. + # + # These are implemented as aliases into the Snit runtime library. + + interp alias {} %TYPE%::installhull {} ::snit::RT.installhull %TYPE% + interp alias {} %TYPE%::install {} ::snit::RT.install %TYPE% + interp alias {} %TYPE%::typevariable {} ::variable + interp alias {} %TYPE%::variable {} ::snit::RT.variable + interp alias {} %TYPE%::mytypevar {} ::snit::RT.mytypevar %TYPE% + interp alias {} %TYPE%::typevarname {} ::snit::RT.mytypevar %TYPE% + interp alias {} %TYPE%::myvar {} ::snit::RT.myvar + interp alias {} %TYPE%::varname {} ::snit::RT.myvar + interp alias {} %TYPE%::codename {} ::snit::RT.codename %TYPE% + interp alias {} %TYPE%::myproc {} ::snit::RT.myproc %TYPE% + interp alias {} %TYPE%::mymethod {} ::snit::RT.mymethod + interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE% + interp alias {} %TYPE%::from {} ::snit::RT.from %TYPE% + + #------------------------------------------------------------------- + # Snit's internal variables + + namespace eval %TYPE% { + # Array: General Snit Info + # + # ns: The type's namespace + # hasinstances: T or F, from pragma -hasinstances. + # simpledispatch: T or F, from pragma -hasinstances. + # canreplace: T or F, from pragma -canreplace. + # counter: Count of instances created so far. + # widgetclass: Set by widgetclass statement. + # hulltype: Hull type (frame or toplevel) for widgets only. + # exceptmethods: Methods explicitly not delegated to * + # excepttypemethods: Methods explicitly not delegated to * + # tvardecs: Type variable declarations--for dynamic methods + # ivardecs: Instance variable declarations--for dyn. methods + typevariable Snit_info + set Snit_info(ns) %TYPE%:: + set Snit_info(hasinstances) 1 + set Snit_info(simpledispatch) 0 + set Snit_info(canreplace) 0 + set Snit_info(counter) 0 + set Snit_info(widgetclass) {} + set Snit_info(hulltype) frame + set Snit_info(exceptmethods) {} + set Snit_info(excepttypemethods) {} + set Snit_info(tvardecs) {%TVARDECS%} + set Snit_info(ivardecs) {%IVARDECS%} + + # Array: Public methods of this type. + # The index is the method name, or "*". + # The value is [list $pattern $componentName], where + # $componentName is "" for normal methods. + typevariable Snit_typemethodInfo + array unset Snit_typemethodInfo + + # Array: Public methods of instances of this type. + # The index is the method name, or "*". + # The value is [list $pattern $componentName], where + # $componentName is "" for normal methods. + typevariable Snit_methodInfo + array unset Snit_methodInfo + + # Array: option information. See dictionary.txt. + typevariable Snit_optionInfo + array unset Snit_optionInfo + set Snit_optionInfo(local) {} + set Snit_optionInfo(delegated) {} + set Snit_optionInfo(starcomp) {} + set Snit_optionInfo(except) {} + } + + #---------------------------------------------------------------- + # Compiled Procs + # + # These commands are created or replaced during compilation: + + + # Snit_instanceVars selfns + # + # Initializes the instance variables, if any. Called during + # instance creation. + + proc %TYPE%::Snit_instanceVars {selfns} { + %INSTANCEVARS% + } + + # Type Constructor + proc %TYPE%::Snit_typeconstructor {type} { + %TVARDECS% + namespace path [namespace parent $type] + %TCONSTBODY% + } + + #---------------------------------------------------------------- + # Default Procs + # + # These commands might be replaced during compilation: + + # Snit_destructor type selfns win self + # + # Default destructor for the type. By default, it does + # nothing. It's replaced by any user destructor. + # For types, it's called by method destroy; for widgettypes, + # it's called by a destroy event handler. + + proc %TYPE%::Snit_destructor {type selfns win self} { } + + #---------------------------------------------------------- + # Compiled Definitions + + %COMPILEDDEFS% + + #---------------------------------------------------------- + # Finally, call the Type Constructor + + %TYPE%::Snit_typeconstructor %TYPE% +} + +#----------------------------------------------------------------------- +# Type procs +# +# These procs expect the fully-qualified type name to be +# substituted in for %TYPE%. + +# This is the nominal type proc. It supports typemethods and +# delegated typemethods. +set ::snit::nominalTypeProc { + # WHD: Code for creating the type ensemble + namespace eval %TYPE% { + namespace ensemble create \ + -unknown [list ::snit::RT.UnknownTypemethod %TYPE% ""] \ + -prefixes 0 + } +} + +# This is the simplified type proc for when there are no typemethods +# except create. In this case, it doesn't take a method argument; +# the method is always "create". +set ::snit::simpleTypeProc { + # Type dispatcher function. Note: This function lives + # in the parent of the %TYPE% namespace! All accesses to + # %TYPE% variables and methods must be qualified! + proc %TYPE% {args} { + ::variable %TYPE%::Snit_info + + # FIRST, if the are no args, the single arg is %AUTO% + if {[llength $args] == 0} { + if {$Snit_info(isWidget)} { + error "wrong \# args: should be \"%TYPE% name args\"" + } + + lappend args %AUTO% + } + + # NEXT, we're going to call the create method. + # Pass along the return code unchanged. + if {$Snit_info(isWidget)} { + set command [list ::snit::RT.widget.typemethod.create %TYPE%] + } else { + set command [list ::snit::RT.type.typemethod.create %TYPE%] + } + + set retval [catch {uplevel 1 $command $args} result] + + if {$retval} { + if {$retval == 1} { + global errorInfo + global errorCode + return -code error -errorinfo $errorInfo \ + -errorcode $errorCode $result + } else { + return -code $retval $result + } + } + + return $result + } +} + +#======================================================================= +# Snit Type Definition +# +# These are the procs used to define Snit types, widgets, and +# widgetadaptors. + + +#----------------------------------------------------------------------- +# Snit Compilation Variables +# +# The following variables are used while Snit is compiling a type, +# and are disposed afterwards. + +namespace eval ::snit:: { + # The compiler variable contains the name of the slave interpreter + # used to compile type definitions. + variable compiler "" + + # The compile array accumulates information about the type or + # widgettype being compiled. It is cleared before and after each + # compilation. It has these indices: + # + # type: The name of the type being compiled, for use + # in compilation procs. + # defs: Compiled definitions, both standard and client. + # which: type, widget, widgetadaptor + # instancevars: Instance variable definitions and initializations. + # ivprocdec: Instance variable proc declarations. + # tvprocdec: Type variable proc declarations. + # typeconstructor: Type constructor body. + # widgetclass: The widgetclass, for snit::widgets, only + # hasoptions: False, initially; set to true when first + # option is defined. + # localoptions: Names of local options. + # delegatedoptions: Names of delegated options. + # localmethods: Names of locally defined methods. + # delegatesmethods: no if no delegated methods, yes otherwise. + # hashierarchic : no if no hierarchic methods, yes otherwise. + # components: Names of defined components. + # typecomponents: Names of defined typecomponents. + # typevars: Typevariable definitions and initializations. + # varnames: Names of instance variables + # typevarnames Names of type variables + # hasconstructor False, initially; true when constructor is + # defined. + # resource-$opt The option's resource name + # class-$opt The option's class + # -default-$opt The option's default value + # -validatemethod-$opt The option's validate method + # -configuremethod-$opt The option's configure method + # -cgetmethod-$opt The option's cget method. + # -hastypeinfo The -hastypeinfo pragma + # -hastypedestroy The -hastypedestroy pragma + # -hastypemethods The -hastypemethods pragma + # -hasinfo The -hasinfo pragma + # -hasinstances The -hasinstances pragma + # -simpledispatch The -simpledispatch pragma WHD: OBSOLETE + # -canreplace The -canreplace pragma + variable compile + + # This variable accumulates method dispatch information; it has + # the same structure as the %TYPE%::Snit_methodInfo array, and is + # used to initialize it. + variable methodInfo + + # This variable accumulates typemethod dispatch information; it has + # the same structure as the %TYPE%::Snit_typemethodInfo array, and is + # used to initialize it. + variable typemethodInfo + + # The following variable lists the reserved type definition statement + # names, e.g., the names you can't use as macros. It's built at + # compiler definition time using "info commands". + variable reservedwords {} +} + +#----------------------------------------------------------------------- +# type compilation commands +# +# The type and widgettype commands use a slave interpreter to compile +# the type definition. These are the procs +# that are aliased into it. + +# Initialize the compiler +proc ::snit::Comp.Init {} { + variable compiler + variable reservedwords + + if {$compiler eq ""} { + # Create the compiler's interpreter + set compiler [interp create] + + # Initialize the interpreter + $compiler eval { + catch {close stdout} + catch {close stderr} + catch {close stdin} + + # Load package information + # TBD: see if this can be moved outside. + # @mdgen NODEP: ::snit::__does_not_exist__ + catch {package require ::snit::__does_not_exist__} + + # Protect some Tcl commands our type definitions + # will shadow. + rename proc _proc + rename variable _variable + } + + # Define compilation aliases. + $compiler alias pragma ::snit::Comp.statement.pragma + $compiler alias widgetclass ::snit::Comp.statement.widgetclass + $compiler alias hulltype ::snit::Comp.statement.hulltype + $compiler alias constructor ::snit::Comp.statement.constructor + $compiler alias destructor ::snit::Comp.statement.destructor + $compiler alias option ::snit::Comp.statement.option + $compiler alias oncget ::snit::Comp.statement.oncget + $compiler alias onconfigure ::snit::Comp.statement.onconfigure + $compiler alias method ::snit::Comp.statement.method + $compiler alias typemethod ::snit::Comp.statement.typemethod + $compiler alias typeconstructor ::snit::Comp.statement.typeconstructor + $compiler alias proc ::snit::Comp.statement.proc + $compiler alias typevariable ::snit::Comp.statement.typevariable + $compiler alias variable ::snit::Comp.statement.variable + $compiler alias typecomponent ::snit::Comp.statement.typecomponent + $compiler alias component ::snit::Comp.statement.component + $compiler alias delegate ::snit::Comp.statement.delegate + $compiler alias expose ::snit::Comp.statement.expose + + # Get the list of reserved words + set reservedwords [$compiler eval {info commands}] + } +} + +# Compile a type definition, and return the results as a list of two +# items: the fully-qualified type name, and a script that will define +# the type when executed. +# +# which type, widget, or widgetadaptor +# type the type name +# body the type definition +proc ::snit::Comp.Compile {which type body} { + variable typeTemplate + variable nominalTypeProc + variable simpleTypeProc + variable compile + variable compiler + variable methodInfo + variable typemethodInfo + + # FIRST, qualify the name. + if {![string match "::*" $type]} { + # Get caller's namespace; + # append :: if not global namespace. + set ns [uplevel 2 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set type "$ns$type" + } + + # NEXT, create and initialize the compiler, if needed. + Comp.Init + + # NEXT, initialize the class data + array unset methodInfo + array unset typemethodInfo + + array unset compile + set compile(type) $type + set compile(defs) {} + set compile(which) $which + set compile(hasoptions) no + set compile(localoptions) {} + set compile(instancevars) {} + set compile(typevars) {} + set compile(delegatedoptions) {} + set compile(ivprocdec) {} + set compile(tvprocdec) {} + set compile(typeconstructor) {} + set compile(widgetclass) {} + set compile(hulltype) {} + set compile(localmethods) {} + set compile(delegatesmethods) no + set compile(hashierarchic) no + set compile(components) {} + set compile(typecomponents) {} + set compile(varnames) {} + set compile(typevarnames) {} + set compile(hasconstructor) no + set compile(-hastypedestroy) yes + set compile(-hastypeinfo) yes + set compile(-hastypemethods) yes + set compile(-hasinfo) yes + set compile(-hasinstances) yes + set compile(-canreplace) no + + set isWidget [string match widget* $which] + set isWidgetAdaptor [string match widgetadaptor $which] + + # NEXT, Evaluate the type's definition in the class interpreter. + $compiler eval $body + + # NEXT, Add the standard definitions + append compile(defs) \ + "\nset %TYPE%::Snit_info(isWidget) $isWidget\n" + + append compile(defs) \ + "\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n" + + # Indicate whether the type can create instances that replace + # existing commands. + append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n" + + + # Check pragmas for conflict. + + if {!$compile(-hastypemethods) && !$compile(-hasinstances)} { + error "$which $type has neither typemethods nor instances" + } + + # If there are typemethods, define the standard typemethods and + # the nominal type proc. Otherwise define the simple type proc. + if {$compile(-hastypemethods)} { + # Add the info typemethod unless the pragma forbids it. + if {$compile(-hastypeinfo)} { + Comp.statement.delegate typemethod info \ + using {::snit::RT.typemethod.info %t} + } + + # Add the destroy typemethod unless the pragma forbids it. + if {$compile(-hastypedestroy)} { + Comp.statement.delegate typemethod destroy \ + using {::snit::RT.typemethod.destroy %t} + } + + # Add the nominal type proc. + append compile(defs) $nominalTypeProc + } else { + # Add the simple type proc. + append compile(defs) $simpleTypeProc + } + + # Add standard methods/typemethods that only make sense if the + # type has instances. + if {$compile(-hasinstances)} { + # Add the info method unless the pragma forbids it. + if {$compile(-hasinfo)} { + Comp.statement.delegate method info \ + using {::snit::RT.method.info %t %n %w %s} + } + + # Add the option handling stuff if there are any options. + if {$compile(hasoptions)} { + Comp.statement.variable options + + Comp.statement.delegate method cget \ + using {::snit::RT.method.cget %t %n %w %s} + Comp.statement.delegate method configurelist \ + using {::snit::RT.method.configurelist %t %n %w %s} + Comp.statement.delegate method configure \ + using {::snit::RT.method.configure %t %n %w %s} + } + + # Add a default constructor, if they haven't already defined one. + # If there are options, it will configure args; otherwise it + # will do nothing. + if {!$compile(hasconstructor)} { + if {$compile(hasoptions)} { + Comp.statement.constructor {args} { + $self configurelist $args + } + } else { + Comp.statement.constructor {} {} + } + } + + if {!$isWidget} { + Comp.statement.delegate method destroy \ + using {::snit::RT.method.destroy %t %n %w %s} + + Comp.statement.delegate typemethod create \ + using {::snit::RT.type.typemethod.create %t} + } else { + Comp.statement.delegate typemethod create \ + using {::snit::RT.widget.typemethod.create %t} + } + + # Save the method info. + append compile(defs) \ + "\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n" + } else { + append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n" + } + + # NEXT, compiling the type definition built up a set of information + # about the type's locally defined options; add this information to + # the compiled definition. + Comp.SaveOptionInfo + + # NEXT, compiling the type definition built up a set of information + # about the typemethods; save the typemethod info. + append compile(defs) \ + "\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n" + + # NEXT, if this is a widget define the hull component if it isn't + # already defined. + if {$isWidget} { + Comp.DefineComponent hull + } + + # NEXT, substitute the compiled definition into the type template + # to get the type definition script. + set defscript [Expand $typeTemplate \ + %COMPILEDDEFS% $compile(defs)] + + # NEXT, substitute the defined macros into the type definition script. + # This is done as a separate step so that the compile(defs) can + # contain the macros defined below. + + set defscript [Expand $defscript \ + %TYPE% $type \ + %IVARDECS% $compile(ivprocdec) \ + %TVARDECS% $compile(tvprocdec) \ + %TCONSTBODY% $compile(typeconstructor) \ + %INSTANCEVARS% $compile(instancevars) \ + %TYPEVARS% $compile(typevars) \ + ] + + array unset compile + + return [list $type $defscript] +} + +# Information about locally-defined options is accumulated during +# compilation, but not added to the compiled definition--the option +# statement can appear multiple times, so it's easier this way. +# This proc fills in Snit_optionInfo with the accumulated information. +# +# It also computes the option's resource and class names if needed. +# +# Note that the information for delegated options was put in +# Snit_optionInfo during compilation. + +proc ::snit::Comp.SaveOptionInfo {} { + variable compile + + foreach option $compile(localoptions) { + if {$compile(resource-$option) eq ""} { + set compile(resource-$option) [string range $option 1 end] + } + + if {$compile(class-$option) eq ""} { + set compile(class-$option) [Capitalize $compile(resource-$option)] + } + + # NOTE: Don't verify that the validate, configure, and cget + # values name real methods; the methods might be defined outside + # the typedefinition using snit::method. + + Mappend compile(defs) { + # Option %OPTION% + lappend %TYPE%::Snit_optionInfo(local) %OPTION% + + set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 1 + set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RESOURCE% + set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS% + set %TYPE%::Snit_optionInfo(default-%OPTION%) %DEFAULT% + set %TYPE%::Snit_optionInfo(validate-%OPTION%) %VALIDATE% + set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE% + set %TYPE%::Snit_optionInfo(cget-%OPTION%) %CGET% + set %TYPE%::Snit_optionInfo(readonly-%OPTION%) %READONLY% + set %TYPE%::Snit_optionInfo(typespec-%OPTION%) %TYPESPEC% + } %OPTION% $option \ + %RESOURCE% $compile(resource-$option) \ + %CLASS% $compile(class-$option) \ + %DEFAULT% [list $compile(-default-$option)] \ + %VALIDATE% [list $compile(-validatemethod-$option)] \ + %CONFIGURE% [list $compile(-configuremethod-$option)] \ + %CGET% [list $compile(-cgetmethod-$option)] \ + %READONLY% $compile(-readonly-$option) \ + %TYPESPEC% [list $compile(-type-$option)] + } +} + + +# Evaluates a compiled type definition, thus making the type available. +proc ::snit::Comp.Define {compResult} { + # The compilation result is a list containing the fully qualified + # type name and a script to evaluate to define the type. + set type [lindex $compResult 0] + set defscript [lindex $compResult 1] + + # Execute the type definition script. + # Consider using namespace eval %TYPE%. See if it's faster. + if {[catch {eval $defscript} result]} { + namespace delete $type + catch {rename $type ""} + error $result + } + + return $type +} + +# Sets pragma options which control how the type is defined. +proc ::snit::Comp.statement.pragma {args} { + variable compile + + set errRoot "Error in \"pragma...\"" + + foreach {opt val} $args { + switch -exact -- $opt { + -hastypeinfo - + -hastypedestroy - + -hastypemethods - + -hasinstances - + -simpledispatch - + -hasinfo - + -canreplace { + if {![string is boolean -strict $val]} { + error "$errRoot, \"$opt\" requires a boolean value" + } + set compile($opt) $val + } + default { + error "$errRoot, unknown pragma" + } + } + } +} + +# Defines a widget's option class name. +# This statement is only available for snit::widgets, +# not for snit::types or snit::widgetadaptors. +proc ::snit::Comp.statement.widgetclass {name} { + variable compile + + # First, widgetclass can only be set for true widgets + if {"widget" != $compile(which)} { + error "widgetclass cannot be set for snit::$compile(which)s" + } + + # Next, validate the option name. We'll require that it begin + # with an uppercase letter. + set initial [string index $name 0] + if {![string is upper $initial]} { + error "widgetclass \"$name\" does not begin with an uppercase letter" + } + + if {"" != $compile(widgetclass)} { + error "too many widgetclass statements" + } + + # Next, save it. + Mappend compile(defs) { + set %TYPE%::Snit_info(widgetclass) %WIDGETCLASS% + } %WIDGETCLASS% [list $name] + + set compile(widgetclass) $name +} + +# Defines a widget's hull type. +# This statement is only available for snit::widgets, +# not for snit::types or snit::widgetadaptors. +proc ::snit::Comp.statement.hulltype {name} { + variable compile + variable hulltypes + + # First, hulltype can only be set for true widgets + if {"widget" != $compile(which)} { + error "hulltype cannot be set for snit::$compile(which)s" + } + + # Next, it must be one of the valid hulltypes (frame, toplevel, ...) + if {[lsearch -exact $hulltypes [string trimleft $name :]] == -1} { + error "invalid hulltype \"$name\", should be one of\ + [join $hulltypes {, }]" + } + + if {"" != $compile(hulltype)} { + error "too many hulltype statements" + } + + # Next, save it. + Mappend compile(defs) { + set %TYPE%::Snit_info(hulltype) %HULLTYPE% + } %HULLTYPE% $name + + set compile(hulltype) $name +} + +# Defines a constructor. +proc ::snit::Comp.statement.constructor {arglist body} { + variable compile + + CheckArgs "constructor" $arglist + + # Next, add a magic reference to self. + set arglist [concat type selfns win self $arglist] + + # Next, add variable declarations to body: + set body "%TVARDECS%\n%IVARDECS%\n$body" + + set compile(hasconstructor) yes + append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n" +} + +# Defines a destructor. +proc ::snit::Comp.statement.destructor {body} { + variable compile + + # Next, add variable declarations to body: + set body "%TVARDECS%\n%IVARDECS%\n$body" + + append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]\n\n" +} + +# Defines a type option. The option value can be a triple, specifying +# the option's -name, resource name, and class name. +proc ::snit::Comp.statement.option {optionDef args} { + variable compile + + # First, get the three option names. + set option [lindex $optionDef 0] + set resourceName [lindex $optionDef 1] + set className [lindex $optionDef 2] + + set errRoot "Error in \"option [list $optionDef]...\"" + + # Next, validate the option name. + if {![Comp.OptionNameIsValid $option]} { + error "$errRoot, badly named option \"$option\"" + } + + if {$option in $compile(delegatedoptions)} { + error "$errRoot, cannot define \"$option\" locally, it has been delegated" + } + + if {!($option in $compile(localoptions))} { + # Remember that we've seen this one. + set compile(hasoptions) yes + lappend compile(localoptions) $option + + # Initialize compilation info for this option. + set compile(resource-$option) "" + set compile(class-$option) "" + set compile(-default-$option) "" + set compile(-validatemethod-$option) "" + set compile(-configuremethod-$option) "" + set compile(-cgetmethod-$option) "" + set compile(-readonly-$option) 0 + set compile(-type-$option) "" + } + + # NEXT, see if we have a resource name. If so, make sure it + # isn't being redefined differently. + if {$resourceName ne ""} { + if {$compile(resource-$option) eq ""} { + # If it's undefined, just save the value. + set compile(resource-$option) $resourceName + } elseif {$resourceName ne $compile(resource-$option)} { + # It's been redefined differently. + error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\"" + } + } + + # NEXT, see if we have a class name. If so, make sure it + # isn't being redefined differently. + if {$className ne ""} { + if {$compile(class-$option) eq ""} { + # If it's undefined, just save the value. + set compile(class-$option) $className + } elseif {$className ne $compile(class-$option)} { + # It's been redefined differently. + error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\"" + } + } + + # NEXT, handle the args; it's not an error to redefine these. + if {[llength $args] == 1} { + set compile(-default-$option) [lindex $args 0] + } else { + foreach {optopt val} $args { + switch -exact -- $optopt { + -default - + -validatemethod - + -configuremethod - + -cgetmethod { + set compile($optopt-$option) $val + } + -type { + set compile($optopt-$option) $val + + if {[llength $val] == 1} { + # The type spec *is* the validation object + append compile(defs) \ + "\nset %TYPE%::Snit_optionInfo(typeobj-$option) [list $val]\n" + } else { + # Compilation the creation of the validation object + set cmd [linsert $val 1 %TYPE%::Snit_TypeObj_%AUTO%] + append compile(defs) \ + "\nset %TYPE%::Snit_optionInfo(typeobj-$option) \[$cmd\]\n" + } + } + -readonly { + if {![string is boolean -strict $val]} { + error "$errRoot, -readonly requires a boolean, got \"$val\"" + } + set compile($optopt-$option) $val + } + default { + error "$errRoot, unknown option definition option \"$optopt\"" + } + } + } + } +} + +# 1 if the option name is valid, 0 otherwise. +proc ::snit::Comp.OptionNameIsValid {option} { + if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} { + return 0 + } + + return 1 +} + +# Defines an option's cget handler +proc ::snit::Comp.statement.oncget {option body} { + variable compile + + set errRoot "Error in \"oncget $option...\"" + + if {[lsearch -exact $compile(delegatedoptions) $option] != -1} { + return -code error "$errRoot, option \"$option\" is delegated" + } + + if {[lsearch -exact $compile(localoptions) $option] == -1} { + return -code error "$errRoot, option \"$option\" unknown" + } + + Comp.statement.method _cget$option {_option} $body + Comp.statement.option $option -cgetmethod _cget$option +} + +# Defines an option's configure handler. +proc ::snit::Comp.statement.onconfigure {option arglist body} { + variable compile + + if {[lsearch -exact $compile(delegatedoptions) $option] != -1} { + return -code error "onconfigure $option: option \"$option\" is delegated" + } + + if {[lsearch -exact $compile(localoptions) $option] == -1} { + return -code error "onconfigure $option: option \"$option\" unknown" + } + + if {[llength $arglist] != 1} { + error \ + "onconfigure $option handler should have one argument, got \"$arglist\"" + } + + CheckArgs "onconfigure $option" $arglist + + # Next, add a magic reference to the option name + set arglist [concat _option $arglist] + + Comp.statement.method _configure$option $arglist $body + Comp.statement.option $option -configuremethod _configure$option +} + +# Defines an instance method. +proc ::snit::Comp.statement.method {method arglist body} { + variable compile + variable methodInfo + + # FIRST, check the method name against previously defined + # methods. + Comp.CheckMethodName $method 0 ::snit::methodInfo \ + "Error in \"method [list $method]...\"" + + if {[llength $method] > 1} { + set compile(hashierarchic) yes + } + + # Remeber this method + lappend compile(localmethods) $method + + CheckArgs "method [list $method]" $arglist + + # Next, add magic references to type and self. + set arglist [concat type selfns win self $arglist] + + # Next, add variable declarations to body: + set body "%TVARDECS%\n%IVARDECS%\n# END snit method prolog\n$body" + + # Next, save the definition script. + if {[llength $method] == 1} { + set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""} + Mappend compile(defs) { + proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY% + } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body] + } else { + set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""} + + Mappend compile(defs) { + proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY% + } %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \ + %BODY% [list $body] + } +} + +# Check for name collisions; save prefix information. +# +# method The name of the method or typemethod. +# delFlag 1 if delegated, 0 otherwise. +# infoVar The fully qualified name of the array containing +# information about the defined methods. +# errRoot The root string for any error messages. + +proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} { + upvar $infoVar methodInfo + + # FIRST, make sure the method name is a valid Tcl list. + if {[catch {lindex $method 0}]} { + error "$errRoot, the name \"$method\" must have list syntax." + } + + # NEXT, check whether we can define it. + if {![catch {set methodInfo($method)} data]} { + # We can't redefine methods with submethods. + if {[lindex $data 0] == 1} { + error "$errRoot, \"$method\" has submethods." + } + + # You can't delegate a method that's defined locally, + # and you can't define a method locally if it's been delegated. + if {$delFlag && [lindex $data 2] eq ""} { + error "$errRoot, \"$method\" has been defined locally." + } elseif {!$delFlag && [lindex $data 2] ne ""} { + error "$errRoot, \"$method\" has been delegated" + } + } + + # Handle hierarchical case. + if {[llength $method] > 1} { + set prefix {} + set tokens $method + while {[llength $tokens] > 1} { + lappend prefix [lindex $tokens 0] + set tokens [lrange $tokens 1 end] + + if {![catch {set methodInfo($prefix)} result]} { + # Prefix is known. If it's not a prefix, throw an + # error. + if {[lindex $result 0] == 0} { + error "$errRoot, \"$prefix\" has no submethods." + } + } + + set methodInfo($prefix) [list 1] + } + } +} + +# Defines a typemethod method. +proc ::snit::Comp.statement.typemethod {method arglist body} { + variable compile + variable typemethodInfo + + # FIRST, check the typemethod name against previously defined + # typemethods. + Comp.CheckMethodName $method 0 ::snit::typemethodInfo \ + "Error in \"typemethod [list $method]...\"" + + CheckArgs "typemethod $method" $arglist + + # First, add magic reference to type. + set arglist [concat type $arglist] + + # Next, add typevariable declarations to body: + set body "%TVARDECS%\n# END snit method prolog\n$body" + + # Next, save the definition script + if {[llength $method] == 1} { + set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""} + + Mappend compile(defs) { + proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY% + } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body] + } else { + set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""} + + Mappend compile(defs) { + proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY% + } %JMETHOD% [join $method _] \ + %ARGLIST% [list $arglist] %BODY% [list $body] + } +} + + +# Defines a type constructor. +proc ::snit::Comp.statement.typeconstructor {body} { + variable compile + + if {"" != $compile(typeconstructor)} { + error "too many typeconstructors" + } + + set compile(typeconstructor) $body +} + +# Defines a static proc in the type's namespace. +proc ::snit::Comp.statement.proc {proc arglist body} { + variable compile + + # If "ns" is defined, the proc can see instance variables. + if {[lsearch -exact $arglist selfns] != -1} { + # Next, add instance variable declarations to body: + set body "%IVARDECS%\n$body" + } + + # The proc can always see typevariables. + set body "%TVARDECS%\n$body" + + append compile(defs) " + + # Proc $proc + proc [list %TYPE%::$proc $arglist $body] + " +} + +# Defines a static variable in the type's namespace. +proc ::snit::Comp.statement.typevariable {name args} { + variable compile + + set errRoot "Error in \"typevariable $name...\"" + + set len [llength $args] + + if {$len > 2 || + ($len == 2 && [lindex $args 0] ne "-array")} { + error "$errRoot, too many initializers" + } + + if {[lsearch -exact $compile(varnames) $name] != -1} { + error "$errRoot, \"$name\" is already an instance variable" + } + + lappend compile(typevarnames) $name + + if {$len == 1} { + append compile(typevars) \ + "\n\t [list ::variable $name [lindex $args 0]]" + } elseif {$len == 2} { + append compile(typevars) \ + "\n\t [list ::variable $name]" + append compile(typevars) \ + "\n\t [list array set $name [lindex $args 1]]" + } else { + append compile(typevars) \ + "\n\t [list ::variable $name]" + } + + if {$compile(tvprocdec) eq ""} { + set compile(tvprocdec) "\n\t" + append compile(tvprocdec) "namespace upvar [list $compile(type)]" + } + append compile(tvprocdec) " [list $name $name]" +} + +# Defines an instance variable; the definition will go in the +# type's create typemethod. +proc ::snit::Comp.statement.variable {name args} { + variable compile + + set errRoot "Error in \"variable $name...\"" + + set len [llength $args] + + if {$len > 2 || + ($len == 2 && [lindex $args 0] ne "-array")} { + error "$errRoot, too many initializers" + } + + if {[lsearch -exact $compile(typevarnames) $name] != -1} { + error "$errRoot, \"$name\" is already a typevariable" + } + + lappend compile(varnames) $name + + # Add a ::variable to instancevars, so that ::variable is used + # at least once; ::variable makes the variable visible to + # [info vars] even if no value is assigned. + append compile(instancevars) "\n" + Mappend compile(instancevars) {::variable ${selfns}::%N} %N $name + + if {$len == 1} { + append compile(instancevars) \ + "\nset $name [list [lindex $args 0]]\n" + } elseif {$len == 2} { + append compile(instancevars) \ + "\narray set $name [list [lindex $args 1]]\n" + } + + if {$compile(ivprocdec) eq ""} { + set compile(ivprocdec) "\n\t" + append compile(ivprocdec) {namespace upvar $selfns} + } + append compile(ivprocdec) " [list $name $name]" +} + +# Defines a typecomponent, and handles component options. +# +# component The logical name of the delegate +# args options. + +proc ::snit::Comp.statement.typecomponent {component args} { + variable compile + + set errRoot "Error in \"typecomponent $component...\"" + + # FIRST, define the component + Comp.DefineTypecomponent $component $errRoot + + # NEXT, handle the options. + set publicMethod "" + set inheritFlag 0 + + foreach {opt val} $args { + switch -exact -- $opt { + -public { + set publicMethod $val + } + -inherit { + set inheritFlag $val + if {![string is boolean $inheritFlag]} { + error "typecomponent $component -inherit: expected boolean value, got \"$val\"" + } + } + default { + error "typecomponent $component: Invalid option \"$opt\"" + } + } + } + + # NEXT, if -public specified, define the method. + if {$publicMethod ne ""} { + Comp.statement.delegate typemethod [list $publicMethod *] to $component + } + + # NEXT, if "-inherit 1" is specified, delegate typemethod * to + # this component. + if {$inheritFlag} { + Comp.statement.delegate typemethod "*" to $component + } + +} + + +# Defines a name to be a typecomponent +# +# The name becomes a typevariable; in addition, it gets a +# write trace so that when it is set, all of the component mechanisms +# get updated. +# +# component The component name + +proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} { + variable compile + + if {[lsearch -exact $compile(varnames) $component] != -1} { + error "$errRoot, \"$component\" is already an instance variable" + } + + if {[lsearch -exact $compile(typecomponents) $component] == -1} { + # Remember we've done this. + lappend compile(typecomponents) $component + + # Make it a type variable with no initial value + Comp.statement.typevariable $component "" + + # Add a write trace to do the component thing. + Mappend compile(typevars) { + trace add variable %COMP% write \ + [list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%] + } %TYPE% $compile(type) %COMP% $component + } +} + +# Defines a component, and handles component options. +# +# component The logical name of the delegate +# args options. +# +# TBD: Ideally, it should be possible to call this statement multiple +# times, possibly changing the option values. To do that, I'd need +# to cache the option values and not act on them until *after* I'd +# read the entire type definition. + +proc ::snit::Comp.statement.component {component args} { + variable compile + + set errRoot "Error in \"component $component...\"" + + # FIRST, define the component + Comp.DefineComponent $component $errRoot + + # NEXT, handle the options. + set publicMethod "" + set inheritFlag 0 + + foreach {opt val} $args { + switch -exact -- $opt { + -public { + set publicMethod $val + } + -inherit { + set inheritFlag $val + if {![string is boolean $inheritFlag]} { + error "component $component -inherit: expected boolean value, got \"$val\"" + } + } + default { + error "component $component: Invalid option \"$opt\"" + } + } + } + + # NEXT, if -public specified, define the method. + if {$publicMethod ne ""} { + Comp.statement.delegate method [list $publicMethod *] to $component + } + + # NEXT, if -inherit is specified, delegate method/option * to + # this component. + if {$inheritFlag} { + Comp.statement.delegate method "*" to $component + Comp.statement.delegate option "*" to $component + } +} + + +# Defines a name to be a component +# +# The name becomes an instance variable; in addition, it gets a +# write trace so that when it is set, all of the component mechanisms +# get updated. +# +# component The component name + +proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} { + variable compile + + if {[lsearch -exact $compile(typevarnames) $component] != -1} { + error "$errRoot, \"$component\" is already a typevariable" + } + + if {[lsearch -exact $compile(components) $component] == -1} { + # Remember we've done this. + lappend compile(components) $component + + # Make it an instance variable with no initial value + Comp.statement.variable $component "" + + # Add a write trace to do the component thing. + Mappend compile(instancevars) { + trace add variable ${selfns}::%COMP% write \ + [list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%] + } %TYPE% $compile(type) %COMP% $component + } +} + +# Creates a delegated method, typemethod, or option. +proc ::snit::Comp.statement.delegate {what name args} { + # FIRST, dispatch to correct handler. + switch $what { + typemethod { Comp.DelegatedTypemethod $name $args } + method { Comp.DelegatedMethod $name $args } + option { Comp.DelegatedOption $name $args } + default { + error "Error in \"delegate $what $name...\", \"$what\"?" + } + } + + if {([llength $args] % 2) != 0} { + error "Error in \"delegate $what $name...\", invalid syntax" + } +} + +# Creates a delegated typemethod delegating it to a particular +# typecomponent or an arbitrary command. +# +# method The name of the method +# arglist Delegation options + +proc ::snit::Comp.DelegatedTypemethod {method arglist} { + variable compile + variable typemethodInfo + + set errRoot "Error in \"delegate typemethod [list $method]...\"" + + # Next, parse the delegation options. + set component "" + set target "" + set exceptions {} + set pattern "" + set methodTail [lindex $method end] + + foreach {opt value} $arglist { + switch -exact $opt { + to { set component $value } + as { set target $value } + except { set exceptions $value } + using { set pattern $value } + default { + error "$errRoot, unknown delegation option \"$opt\"" + } + } + } + + if {$component eq "" && $pattern eq ""} { + error "$errRoot, missing \"to\"" + } + + if {$methodTail eq "*" && $target ne ""} { + error "$errRoot, cannot specify \"as\" with \"*\"" + } + + if {$methodTail ne "*" && $exceptions ne ""} { + error "$errRoot, can only specify \"except\" with \"*\"" + } + + if {$pattern ne "" && $target ne ""} { + error "$errRoot, cannot specify both \"as\" and \"using\"" + } + + foreach token [lrange $method 1 end-1] { + if {$token eq "*"} { + error "$errRoot, \"*\" must be the last token." + } + } + + # NEXT, define the component + if {$component ne ""} { + Comp.DefineTypecomponent $component $errRoot + } + + # NEXT, define the pattern. + if {$pattern eq ""} { + if {$methodTail eq "*"} { + set pattern "%c %m" + } elseif {$target ne ""} { + set pattern "%c $target" + } else { + set pattern "%c %m" + } + } + + # Make sure the pattern is a valid list. + if {[catch {lindex $pattern 0} result]} { + error "$errRoot, the using pattern, \"$pattern\", is not a valid list" + } + + # NEXT, check the method name against previously defined + # methods. + Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot + + set typemethodInfo($method) [list 0 $pattern $component] + + if {[string equal $methodTail "*"]} { + Mappend compile(defs) { + set %TYPE%::Snit_info(excepttypemethods) %EXCEPT% + } %EXCEPT% [list $exceptions] + } +} + + +# Creates a delegated method delegating it to a particular +# component or command. +# +# method The name of the method +# arglist Delegation options. + +proc ::snit::Comp.DelegatedMethod {method arglist} { + variable compile + variable methodInfo + + set errRoot "Error in \"delegate method [list $method]...\"" + + # Next, parse the delegation options. + set component "" + set target "" + set exceptions {} + set pattern "" + set methodTail [lindex $method end] + + foreach {opt value} $arglist { + switch -exact $opt { + to { set component $value } + as { set target $value } + except { set exceptions $value } + using { set pattern $value } + default { + error "$errRoot, unknown delegation option \"$opt\"" + } + } + } + + if {$component eq "" && $pattern eq ""} { + error "$errRoot, missing \"to\"" + } + + if {$methodTail eq "*" && $target ne ""} { + error "$errRoot, cannot specify \"as\" with \"*\"" + } + + if {$methodTail ne "*" && $exceptions ne ""} { + error "$errRoot, can only specify \"except\" with \"*\"" + } + + if {$pattern ne "" && $target ne ""} { + error "$errRoot, cannot specify both \"as\" and \"using\"" + } + + foreach token [lrange $method 1 end-1] { + if {$token eq "*"} { + error "$errRoot, \"*\" must be the last token." + } + } + + # NEXT, we delegate some methods + set compile(delegatesmethods) yes + + # NEXT, define the component. Allow typecomponents. + if {$component ne ""} { + if {[lsearch -exact $compile(typecomponents) $component] == -1} { + Comp.DefineComponent $component $errRoot + } + } + + # NEXT, define the pattern. + if {$pattern eq ""} { + if {$methodTail eq "*"} { + set pattern "%c %m" + } elseif {$target ne ""} { + set pattern "%c $target" + } else { + set pattern "%c %m" + } + } + + # Make sure the pattern is a valid list. + if {[catch {lindex $pattern 0} result]} { + error "$errRoot, the using pattern, \"$pattern\", is not a valid list" + } + + # NEXT, check the method name against previously defined + # methods. + Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot + + # NEXT, save the method info. + set methodInfo($method) [list 0 $pattern $component] + + if {[string equal $methodTail "*"]} { + Mappend compile(defs) { + set %TYPE%::Snit_info(exceptmethods) %EXCEPT% + } %EXCEPT% [list $exceptions] + } +} + +# Creates a delegated option, delegating it to a particular +# component and, optionally, to a particular option of that +# component. +# +# optionDef The option definition +# args definition arguments. + +proc ::snit::Comp.DelegatedOption {optionDef arglist} { + variable compile + + # First, get the three option names. + set option [lindex $optionDef 0] + set resourceName [lindex $optionDef 1] + set className [lindex $optionDef 2] + + set errRoot "Error in \"delegate option [list $optionDef]...\"" + + # Next, parse the delegation options. + set component "" + set target "" + set exceptions {} + + foreach {opt value} $arglist { + switch -exact $opt { + to { set component $value } + as { set target $value } + except { set exceptions $value } + default { + error "$errRoot, unknown delegation option \"$opt\"" + } + } + } + + if {$component eq ""} { + error "$errRoot, missing \"to\"" + } + + if {$option eq "*" && $target ne ""} { + error "$errRoot, cannot specify \"as\" with \"delegate option *\"" + } + + if {$option ne "*" && $exceptions ne ""} { + error "$errRoot, can only specify \"except\" with \"delegate option *\"" + } + + # Next, validate the option name + + if {"*" != $option} { + if {![Comp.OptionNameIsValid $option]} { + error "$errRoot, badly named option \"$option\"" + } + } + + if {$option in $compile(localoptions)} { + error "$errRoot, \"$option\" has been defined locally" + } + + if {$option in $compile(delegatedoptions)} { + error "$errRoot, \"$option\" is multiply delegated" + } + + # NEXT, define the component + Comp.DefineComponent $component $errRoot + + # Next, define the target option, if not specified. + if {![string equal $option "*"] && + [string equal $target ""]} { + set target $option + } + + # NEXT, save the delegation data. + set compile(hasoptions) yes + + if {![string equal $option "*"]} { + lappend compile(delegatedoptions) $option + + # Next, compute the resource and class names, if they aren't + # already defined. + + if {"" == $resourceName} { + set resourceName [string range $option 1 end] + } + + if {"" == $className} { + set className [Capitalize $resourceName] + } + + Mappend compile(defs) { + set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0 + set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES% + set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS% + lappend %TYPE%::Snit_optionInfo(delegated) %OPTION% + set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%] + lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION% + } %OPTION% $option \ + %COMP% $component \ + %TARGET% $target \ + %RES% $resourceName \ + %CLASS% $className + } else { + Mappend compile(defs) { + set %TYPE%::Snit_optionInfo(starcomp) %COMP% + set %TYPE%::Snit_optionInfo(except) %EXCEPT% + } %COMP% $component %EXCEPT% [list $exceptions] + } +} + +# Exposes a component, effectively making the component's command an +# instance method. +# +# component The logical name of the delegate +# "as" sugar; if not "", must be "as" +# methodname The desired method name for the component's command, or "" + +proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} { + variable compile + + + # FIRST, define the component + Comp.DefineComponent $component + + # NEXT, define the method just as though it were in the type + # definition. + if {[string equal $methodname ""]} { + set methodname $component + } + + Comp.statement.method $methodname args [Expand { + if {[llength $args] == 0} { + return $%COMPONENT% + } + + if {[string equal $%COMPONENT% ""]} { + error "undefined component \"%COMPONENT%\"" + } + + + set cmd [linsert $args 0 $%COMPONENT%] + return [uplevel 1 $cmd] + } %COMPONENT% $component] +} + + + +#----------------------------------------------------------------------- +# Public commands + +# Compile a type definition, and return the results as a list of two +# items: the fully-qualified type name, and a script that will define +# the type when executed. +# +# which type, widget, or widgetadaptor +# type the type name +# body the type definition +proc ::snit::compile {which type body} { + return [Comp.Compile $which $type $body] +} + +proc ::snit::type {type body} { + return [Comp.Define [Comp.Compile type $type $body]] +} + +proc ::snit::widget {type body} { + return [Comp.Define [Comp.Compile widget $type $body]] +} + +proc ::snit::widgetadaptor {type body} { + return [Comp.Define [Comp.Compile widgetadaptor $type $body]] +} + +proc ::snit::typemethod {type method arglist body} { + # Make sure the type exists. + if {![info exists ::${type}::Snit_info]} { + error "no such type: \"$type\"" + } + + upvar ::${type}::Snit_info Snit_info + upvar ::${type}::Snit_typemethodInfo Snit_typemethodInfo + + # FIRST, check the typemethod name against previously defined + # typemethods. + Comp.CheckMethodName $method 0 ::${type}::Snit_typemethodInfo \ + "Cannot define \"$method\"" + + # NEXT, check the arguments + CheckArgs "snit::typemethod $type $method" $arglist + + # Next, add magic reference to type. + set arglist [concat type $arglist] + + # Next, add typevariable declarations to body: + set body "$Snit_info(tvardecs)\n$body" + + # Next, define it. + if {[llength $method] == 1} { + set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""} + uplevel 1 [list proc ${type}::Snit_typemethod$method $arglist $body] + } else { + set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""} + set suffix [join $method _] + uplevel 1 [list proc ${type}::Snit_htypemethod$suffix $arglist $body] + } +} + +proc ::snit::method {type method arglist body} { + # Make sure the type exists. + if {![info exists ::${type}::Snit_info]} { + error "no such type: \"$type\"" + } + + upvar ::${type}::Snit_methodInfo Snit_methodInfo + upvar ::${type}::Snit_info Snit_info + + # FIRST, check the method name against previously defined + # methods. + Comp.CheckMethodName $method 0 ::${type}::Snit_methodInfo \ + "Cannot define \"$method\"" + + # NEXT, check the arguments + CheckArgs "snit::method $type $method" $arglist + + # Next, add magic references to type and self. + set arglist [concat type selfns win self $arglist] + + # Next, add variable declarations to body: + set body "$Snit_info(tvardecs)\n$Snit_info(ivardecs)\n$body" + + # Next, define it. + if {[llength $method] == 1} { + set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""} + uplevel 1 [list proc ${type}::Snit_method$method $arglist $body] + } else { + set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""} + + set suffix [join $method _] + uplevel 1 [list proc ${type}::Snit_hmethod$suffix $arglist $body] + } +} + +# Defines a proc within the compiler; this proc can call other +# type definition statements, and thus can be used for meta-programming. +proc ::snit::macro {name arglist body} { + variable compiler + variable reservedwords + + # FIRST, make sure the compiler is defined. + Comp.Init + + # NEXT, check the macro name against the reserved words + if {[lsearch -exact $reservedwords $name] != -1} { + error "invalid macro name \"$name\"" + } + + # NEXT, see if the name has a namespace; if it does, define the + # namespace. + set ns [namespace qualifiers $name] + + if {$ns ne ""} { + $compiler eval "namespace eval $ns {}" + } + + # NEXT, define the macro + $compiler eval [list _proc $name $arglist $body] +} + +#----------------------------------------------------------------------- +# Utility Functions +# +# These are utility functions used while compiling Snit types. + +# Builds a template from a tagged list of text blocks, then substitutes +# all symbols in the mapTable, returning the expanded template. +proc ::snit::Expand {template args} { + return [string map $args $template] +} + +# Expands a template and appends it to a variable. +proc ::snit::Mappend {varname template args} { + upvar $varname myvar + + append myvar [string map $args $template] +} + +# Checks argument list against reserved args +proc ::snit::CheckArgs {which arglist} { + variable reservedArgs + + foreach name $reservedArgs { + if {$name in $arglist} { + error "$which's arglist may not contain \"$name\" explicitly" + } + } +} + +# Capitalizes the first letter of a string. +proc ::snit::Capitalize {text} { + return [string toupper $text 0] +} + + +#======================================================================= +# Snit Runtime Library +# +# These are procs used by Snit types and widgets at runtime. + +#----------------------------------------------------------------------- +# Object Creation + +# Creates a new instance of the snit::type given its name and the args. +# +# type The snit::type +# name The instance name +# args Args to pass to the constructor + +proc ::snit::RT.type.typemethod.create {type name args} { + variable ${type}::Snit_info + variable ${type}::Snit_optionInfo + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; + # append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + + # NEXT, if %AUTO% appears in the name, generate a unique + # command name. Otherwise, ensure that the name isn't in use. + if {[string match "*%AUTO%*" $name]} { + set name [::snit::RT.UniqueName Snit_info(counter) $type $name] + } elseif {!$Snit_info(canreplace) && [llength [info commands $name]]} { + error "command \"$name\" already exists" + } + + # NEXT, create the instance's namespace. + set selfns \ + [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type] + namespace eval $selfns {} + + # NEXT, install the dispatcher + RT.MakeInstanceCommand $type $selfns $name + + # Initialize the options to their defaults. + namespace upvar ${selfns} options options + + foreach opt $Snit_optionInfo(local) { + set options($opt) $Snit_optionInfo(default-$opt) + } + + # Initialize the instance vars to their defaults. + # selfns must be defined, as it is used implicitly. + ${type}::Snit_instanceVars $selfns + + # Execute the type's constructor. + set errcode [catch { + RT.ConstructInstance $type $selfns $name $args + } result] + + if {$errcode} { + global errorInfo + global errorCode + + set theInfo $errorInfo + set theCode $errorCode + + ::snit::RT.DestroyObject $type $selfns $name + error "Error in constructor: $result" $theInfo $theCode + } + + # NEXT, return the object's name. + return $name +} + +# Creates a new instance of the snit::widget or snit::widgetadaptor +# given its name and the args. +# +# type The snit::widget or snit::widgetadaptor +# name The instance name +# args Args to pass to the constructor + +proc ::snit::RT.widget.typemethod.create {type name args} { + variable ${type}::Snit_info + variable ${type}::Snit_optionInfo + + # FIRST, if %AUTO% appears in the name, generate a unique + # command name. + if {[string match "*%AUTO%*" $name]} { + set name [::snit::RT.UniqueName Snit_info(counter) $type $name] + } + + # NEXT, create the instance's namespace. + set selfns \ + [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type] + namespace eval $selfns { } + + # NEXT, Initialize the widget's own options to their defaults. + namespace upvar $selfns options options + + foreach opt $Snit_optionInfo(local) { + set options($opt) $Snit_optionInfo(default-$opt) + } + + # Initialize the instance vars to their defaults. + ${type}::Snit_instanceVars $selfns + + # NEXT, if this is a normal widget (not a widget adaptor) then create a + # frame as its hull. We set the frame's -class to the user's widgetclass, + # or, if none, search for -class in the args list, otherwise default to + # the basename of the $type with an initial upper case letter. + if {!$Snit_info(isWidgetAdaptor)} { + # FIRST, determine the class name + set wclass $Snit_info(widgetclass) + if {$Snit_info(widgetclass) eq ""} { + set idx [lsearch -exact $args -class] + if {$idx >= 0 && ($idx%2 == 0)} { + # -class exists and is in the -option position + set wclass [lindex $args [expr {$idx+1}]] + set args [lreplace $args $idx [expr {$idx+1}]] + } else { + set wclass [::snit::Capitalize [namespace tail $type]] + } + } + + # NEXT, create the widget + set self $name + package require Tk + ${type}::installhull using $Snit_info(hulltype) -class $wclass + + # NEXT, let's query the option database for our + # widget, now that we know that it exists. + foreach opt $Snit_optionInfo(local) { + set dbval [RT.OptionDbGet $type $name $opt] + + if {"" != $dbval} { + set options($opt) $dbval + } + } + } + + # Execute the type's constructor, and verify that it + # has a hull. + set errcode [catch { + RT.ConstructInstance $type $selfns $name $args + + ::snit::RT.Component $type $selfns hull + + # Prepare to call the object's destructor when the + # event is received. Use a Snit-specific bindtag + # so that the widget name's tag is unencumbered. + + bind Snit$type$name [::snit::Expand { + ::snit::RT.DestroyObject %TYPE% %NS% %W + } %TYPE% $type %NS% $selfns] + + # Insert the bindtag into the list of bindtags right + # after the widget name. + set taglist [bindtags $name] + set ndx [lsearch -exact $taglist $name] + incr ndx + bindtags $name [linsert $taglist $ndx Snit$type$name] + } result] + + if {$errcode} { + global errorInfo + global errorCode + + set theInfo $errorInfo + set theCode $errorCode + ::snit::RT.DestroyObject $type $selfns $name + error "Error in constructor: $result" $theInfo $theCode + } + + # NEXT, return the object's name. + return $name +} + + +# RT.MakeInstanceCommand type selfns instance +# +# type The object type +# selfns The instance namespace +# instance The instance name +# +# Creates the instance proc. + +proc ::snit::RT.MakeInstanceCommand {type selfns instance} { + variable ${type}::Snit_info + + # FIRST, remember the instance name. The Snit_instance variable + # allows the instance to figure out its current name given the + # instance namespace. + + namespace upvar $selfns Snit_instance Snit_instance + + set Snit_instance $instance + + # NEXT, qualify the proc name if it's a widget. + if {$Snit_info(isWidget)} { + set procname ::$instance + } else { + set procname $instance + } + + # NEXT, install the new proc + # WHD: Snit 2.0 code + + set unknownCmd [list ::snit::RT.UnknownMethod $type $selfns $instance ""] + set createCmd [list namespace ensemble create \ + -command $procname \ + -unknown $unknownCmd \ + -prefixes 0] + + namespace eval $selfns $createCmd + + # NEXT, add the trace. + trace add command $procname {rename delete} \ + [list ::snit::RT.InstanceTrace $type $selfns $instance] +} + +# This proc is called when the instance command is renamed. +# If op is delete, then new will always be "", so op is redundant. +# +# type The fully-qualified type name +# selfns The instance namespace +# win The original instance/tk window name. +# old old instance command name +# new new instance command name +# op rename or delete +# +# If the op is delete, we need to clean up the object; otherwise, +# we need to track the change. +# +# NOTE: In Tcl 8.4.2 there's a bug: errors in rename and delete +# traces aren't propagated correctly. Instead, they silently +# vanish. Add a catch to output any error message. + +proc ::snit::RT.InstanceTrace {type selfns win old new op} { + variable ${type}::Snit_info + + # Note to developers ... + # For Tcl 8.4.0, errors thrown in trace handlers vanish silently. + # Therefore we catch them here and create some output to help in + # debugging such problems. + + if {[catch { + # FIRST, clean up if necessary + if {"" == $new} { + if {$Snit_info(isWidget)} { + destroy $win + } else { + ::snit::RT.DestroyObject $type $selfns $win + } + } else { + # Otherwise, track the change. + variable ${selfns}::Snit_instance + set Snit_instance [uplevel 1 [list namespace which -command $new]] + + # Also, clear the instance caches, as many cached commands + # might be invalid. + RT.ClearInstanceCaches $selfns + } + } result]} { + global errorInfo + # Pop up the console on Windows wish, to enable stdout. + # This clobbers errorInfo on unix, so save it so we can print it. + set ei $errorInfo + catch {console show} + puts "Error in ::snit::RT.InstanceTrace $type $selfns $win $old $new $op:" + puts $ei + } +} + +# Calls the instance constructor and handles related housekeeping. +proc ::snit::RT.ConstructInstance {type selfns instance arglist} { + variable ${type}::Snit_optionInfo + variable ${selfns}::Snit_iinfo + + # Track whether we are constructed or not. + set Snit_iinfo(constructed) 0 + + # Call the user's constructor + eval [linsert $arglist 0 \ + ${type}::Snit_constructor $type $selfns $instance $instance] + + set Snit_iinfo(constructed) 1 + + # Validate the initial set of options (including defaults) + foreach option $Snit_optionInfo(local) { + set value [set ${selfns}::options($option)] + + if {$Snit_optionInfo(typespec-$option) ne ""} { + if {[catch { + $Snit_optionInfo(typeobj-$option) validate $value + } result]} { + return -code error "invalid $option default: $result" + } + } + } + + # Unset the configure cache for all -readonly options. + # This ensures that the next time anyone tries to + # configure it, an error is thrown. + foreach opt $Snit_optionInfo(local) { + if {$Snit_optionInfo(readonly-$opt)} { + unset -nocomplain ${selfns}::Snit_configureCache($opt) + } + } + + return +} + +# Returns a unique command name. +# +# REQUIRE: type is a fully qualified name. +# REQUIRE: name contains "%AUTO%" +# PROMISE: the returned command name is unused. +proc ::snit::RT.UniqueName {countervar type name} { + upvar $countervar counter + while 1 { + # FIRST, bump the counter and define the %AUTO% instance name; + # then substitute it into the specified name. Wrap around at + # 2^31 - 2 to prevent overflow problems. + incr counter + if {$counter > 2147483646} { + set counter 0 + } + set auto "[namespace tail $type]$counter" + set candidate [Expand $name %AUTO% $auto] + if {![llength [info commands $candidate]]} { + return $candidate + } + } +} + +# Returns a unique instance namespace, fully qualified. +# +# countervar The name of a counter variable +# type The instance's type +# +# REQUIRE: type is fully qualified +# PROMISE: The returned namespace name is unused. + +proc ::snit::RT.UniqueInstanceNamespace {countervar type} { + upvar $countervar counter + while 1 { + # FIRST, bump the counter and define the namespace name. + # Then see if it already exists. Wrap around at + # 2^31 - 2 to prevent overflow problems. + incr counter + if {$counter > 2147483646} { + set counter 0 + } + set ins "${type}::Snit_inst${counter}" + if {![namespace exists $ins]} { + return $ins + } + } +} + +# Retrieves an option's value from the option database. +# Returns "" if no value is found. +proc ::snit::RT.OptionDbGet {type self opt} { + variable ${type}::Snit_optionInfo + + return [option get $self \ + $Snit_optionInfo(resource-$opt) \ + $Snit_optionInfo(class-$opt)] +} + +#----------------------------------------------------------------------- +# Object Destruction + +# Implements the standard "destroy" method +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name + +proc ::snit::RT.method.destroy {type selfns win self} { + variable ${selfns}::Snit_iinfo + + # Can't destroy the object if it isn't complete constructed. + if {!$Snit_iinfo(constructed)} { + return -code error "Called 'destroy' method in constructor" + } + + # Calls Snit_cleanup, which (among other things) calls the + # user's destructor. + ::snit::RT.DestroyObject $type $selfns $win +} + +# This is the function that really cleans up; it's automatically +# called when any instance is destroyed, e.g., by "$object destroy" +# for types, and by the event for widgets. +# +# type The fully-qualified type name. +# selfns The instance namespace +# win The original instance command name. + +proc ::snit::RT.DestroyObject {type selfns win} { + variable ${type}::Snit_info + + # If the variable Snit_instance doesn't exist then there's no + # instance command for this object -- it's most likely a + # widgetadaptor. Consequently, there are some things that + # we don't need to do. + if {[info exists ${selfns}::Snit_instance]} { + namespace upvar $selfns Snit_instance instance + + # First, remove the trace on the instance name, so that we + # don't call RT.DestroyObject recursively. + RT.RemoveInstanceTrace $type $selfns $win $instance + + # Next, call the user's destructor + ${type}::Snit_destructor $type $selfns $win $instance + + # Next, if this isn't a widget, delete the instance command. + # If it is a widget, get the hull component's name, and rename + # it back to the widget name + + # Next, delete the hull component's instance command, + # if there is one. + if {$Snit_info(isWidget)} { + set hullcmd [::snit::RT.Component $type $selfns hull] + + catch {rename $instance ""} + + # Clear the bind event + bind Snit$type$win "" + + if {[llength [info commands $hullcmd]]} { + # FIRST, rename the hull back to its original name. + # If the hull is itself a megawidget, it will have its + # own cleanup to do, and it might not do it properly + # if it doesn't have the right name. + rename $hullcmd ::$instance + + # NEXT, destroy it. + destroy $instance + } + } else { + catch {rename $instance ""} + } + } + + # Next, delete the instance's namespace. This kills any + # instance variables. + namespace delete $selfns + + return +} + +# Remove instance trace +# +# type The fully qualified type name +# selfns The instance namespace +# win The original instance name/Tk window name +# instance The current instance name + +proc ::snit::RT.RemoveInstanceTrace {type selfns win instance} { + variable ${type}::Snit_info + + if {$Snit_info(isWidget)} { + set procname ::$instance + } else { + set procname $instance + } + + # NEXT, remove any trace on this name + catch { + trace remove command $procname {rename delete} \ + [list ::snit::RT.InstanceTrace $type $selfns $win] + } +} + +#----------------------------------------------------------------------- +# Typecomponent Management and Method Caching + +# Typecomponent trace; used for write trace on typecomponent +# variables. Saves the new component object name, provided +# that certain conditions are met. Also clears the typemethod +# cache. + +proc ::snit::RT.TypecomponentTrace {type component n1 n2 op} { + namespace upvar $type \ + Snit_info Snit_info \ + $component cvar \ + Snit_typecomponents Snit_typecomponents + + + # Save the new component value. + set Snit_typecomponents($component) $cvar + + # Clear the typemethod cache. + # TBD: can we unset just the elements related to + # this component? + + # WHD: Namespace 2.0 code + namespace ensemble configure $type -map {} +} + +# WHD: Snit 2.0 code +# +# RT.UnknownTypemethod type eId eCmd method args +# +# type The type +# eId The ensemble command ID; "" for the instance itself. +# eCmd The ensemble command name. +# method The unknown method name. +# args The additional arguments, if any. +# +# This proc looks up the method relative to the specified ensemble. +# If no method is found, it assumes that the "create" method is +# desired, and that the "method" is the instance name. In this case, +# it returns the "create" typemethod command with the instance name +# appended; this will cause the instance to be created without updating +# the -map. If the method is found, the method's command is created and +# added to the -map; the function returns the empty list. + +proc snit::RT.UnknownTypemethod {type eId eCmd method args} { + namespace upvar $type \ + Snit_typemethodInfo Snit_typemethodInfo \ + Snit_typecomponents Snit_typecomponents \ + Snit_info Snit_info + + # FIRST, get the pattern data and the typecomponent name. + set implicitCreate 0 + set instanceName "" + + set fullMethod $eId + lappend fullMethod $method + set starredMethod [concat $eId *] + set methodTail $method + + if {[info exists Snit_typemethodInfo($fullMethod)]} { + set key $fullMethod + } elseif {[info exists Snit_typemethodInfo($starredMethod)]} { + if {[lsearch -exact $Snit_info(excepttypemethods) $methodTail] == -1} { + set key $starredMethod + } else { + # WHD: The method is explicitly not delegated, so this is an error. + # Or should we treat it as an instance name? + return [list ] + } + } elseif {[llength $fullMethod] > 1} { + return [list ] + } elseif {$Snit_info(hasinstances)} { + # Assume the unknown name is an instance name to create, unless + # this is a widget and the style of the name is wrong, or the + # name mimics a standard typemethod. + + if {[set ${type}::Snit_info(isWidget)] && + ![string match ".*" $method]} { + return [list ] + } + + # Without this check, the call "$type info" will redefine the + # standard "::info" command, with disastrous results. Since it's + # a likely thing to do if !-typeinfo, put in an explicit check. + if {$method eq "info" || $method eq "destroy"} { + return [list ] + } + + set implicitCreate 1 + set instanceName $method + set key create + set method create + } else { + return [list ] + } + + foreach {flag pattern compName} $Snit_typemethodInfo($key) {} + + if {$flag == 1} { + # FIRST, define the ensemble command. + lappend eId $method + + set newCmd ${type}::Snit_ten[llength $eId]_[join $eId _] + + set unknownCmd [list ::snit::RT.UnknownTypemethod \ + $type $eId] + + set createCmd [list namespace ensemble create \ + -command $newCmd \ + -unknown $unknownCmd \ + -prefixes 0] + + namespace eval $type $createCmd + + # NEXT, add the method to the current ensemble + set map [namespace ensemble configure $eCmd -map] + + dict append map $method $newCmd + + namespace ensemble configure $eCmd -map $map + + return [list ] + } + + # NEXT, build the substitution list + set subList [list \ + %% % \ + %t $type \ + %M $fullMethod \ + %m [lindex $fullMethod end] \ + %j [join $fullMethod _]] + + if {$compName ne ""} { + if {![info exists Snit_typecomponents($compName)]} { + error "$type delegates typemethod \"$method\" to undefined typecomponent \"$compName\"" + } + + lappend subList %c [list $Snit_typecomponents($compName)] + } + + set command {} + + foreach subpattern $pattern { + lappend command [string map $subList $subpattern] + } + + if {$implicitCreate} { + # In this case, $method is the name of the instance to + # create. Don't cache, as we usually won't do this one + # again. + lappend command $instanceName + return $command + } + + + # NEXT, if the actual command name isn't fully qualified, + # assume it's global. + set cmd [lindex $command 0] + + if {[string index $cmd 0] ne ":"} { + set command [lreplace $command 0 0 "::$cmd"] + } + + # NEXT, update the ensemble map. + set map [namespace ensemble configure $eCmd -map] + + dict append map $method $command + + namespace ensemble configure $eCmd -map $map + + return [list ] +} + +#----------------------------------------------------------------------- +# Component Management and Method Caching + +# Retrieves the object name given the component name. +proc ::snit::RT.Component {type selfns name} { + variable ${selfns}::Snit_components + + if {[catch {set Snit_components($name)} result]} { + variable ${selfns}::Snit_instance + + error "component \"$name\" is undefined in $type $Snit_instance" + } + + return $result +} + +# Component trace; used for write trace on component instance +# variables. Saves the new component object name, provided +# that certain conditions are met. Also clears the method +# cache. + +proc ::snit::RT.ComponentTrace {type selfns component n1 n2 op} { + namespace upvar $type Snit_info Snit_info + namespace upvar $selfns \ + $component cvar \ + Snit_components Snit_components + + # If they try to redefine the hull component after + # it's been defined, that's an error--but only if + # this is a widget or widget adaptor. + if {"hull" == $component && + $Snit_info(isWidget) && + [info exists Snit_components($component)]} { + set cvar $Snit_components($component) + error "The hull component cannot be redefined" + } + + # Save the new component value. + set Snit_components($component) $cvar + + # Clear the instance caches. + # TBD: can we unset just the elements related to + # this component? + RT.ClearInstanceCaches $selfns +} + +# WHD: Snit 2.0 code +# +# RT.UnknownMethod type selfns win eId eCmd method args +# +# type The type or widget command. +# selfns The instance namespace. +# win The original instance name. +# eId The ensemble command ID; "" for the instance itself. +# eCmd The real ensemble command name +# method The unknown method name +# args The additional arguments, if any. +# +# This proc looks up the method relative to the specific ensemble. +# If no method is found, it returns an empty list; this will result in +# the parent ensemble throwing an error. +# If the method is found, the ensemble's -map is extended with the +# correct command, and the empty list is returned; this caches the +# method's command. If the method is found, and it is also an +# ensemble, the ensemble command is created with an empty map. + +proc ::snit::RT.UnknownMethod {type selfns win eId eCmd method args} { + variable ${type}::Snit_info + variable ${type}::Snit_methodInfo + variable ${type}::Snit_typecomponents + variable ${selfns}::Snit_components + + # FIRST, get the "self" value + set self [set ${selfns}::Snit_instance] + + # FIRST, get the pattern data and the component name. + set fullMethod $eId + lappend fullMethod $method + set starredMethod [concat $eId *] + set methodTail $method + + if {[info exists Snit_methodInfo($fullMethod)]} { + set key $fullMethod + } elseif {[info exists Snit_methodInfo($starredMethod)] && + [lsearch -exact $Snit_info(exceptmethods) $methodTail] == -1} { + set key $starredMethod + } else { + return [list ] + } + + foreach {flag pattern compName} $Snit_methodInfo($key) {} + + if {$flag == 1} { + # FIRST, define the ensemble command. + lappend eId $method + + # Fix provided by Anton Kovalenko; previously this call erroneously + # used ${type} rather than ${selfns}. + set newCmd ${selfns}::Snit_en[llength $eId]_[join $eId _] + + set unknownCmd [list ::snit::RT.UnknownMethod \ + $type $selfns $win $eId] + + set createCmd [list namespace ensemble create \ + -command $newCmd \ + -unknown $unknownCmd \ + -prefixes 0] + + namespace eval $selfns $createCmd + + # NEXT, add the method to the current ensemble + set map [namespace ensemble configure $eCmd -map] + + dict append map $method $newCmd + + namespace ensemble configure $eCmd -map $map + + return [list ] + } + + # NEXT, build the substitution list + set subList [list \ + %% % \ + %t $type \ + %M $fullMethod \ + %m [lindex $fullMethod end] \ + %j [join $fullMethod _] \ + %n [list $selfns] \ + %w [list $win] \ + %s [list $self]] + + if {$compName ne ""} { + if {[info exists Snit_components($compName)]} { + set compCmd $Snit_components($compName) + } elseif {[info exists Snit_typecomponents($compName)]} { + set compCmd $Snit_typecomponents($compName) + } else { + error "$type $self delegates method \"$fullMethod\" to undefined component \"$compName\"" + } + + lappend subList %c [list $compCmd] + } + + # Note: The cached command will execute faster if it's + # already a list. + set command {} + + foreach subpattern $pattern { + lappend command [string map $subList $subpattern] + } + + # NEXT, if the actual command name isn't fully qualified, + # assume it's global. + + set cmd [lindex $command 0] + + if {[string index $cmd 0] ne ":"} { + set command [lreplace $command 0 0 "::$cmd"] + } + + # NEXT, update the ensemble map. + set map [namespace ensemble configure $eCmd -map] + + dict append map $method $command + + namespace ensemble configure $eCmd -map $map + + return [list ] +} + +# Clears all instance command caches +proc ::snit::RT.ClearInstanceCaches {selfns} { + # WHD: clear ensemble -map + if {![info exists ${selfns}::Snit_instance]} { + # Component variable set prior to constructor + # via the "variable" type definition statement. + return + } + set self [set ${selfns}::Snit_instance] + namespace ensemble configure $self -map {} + + unset -nocomplain -- ${selfns}::Snit_cgetCache + unset -nocomplain -- ${selfns}::Snit_configureCache + unset -nocomplain -- ${selfns}::Snit_validateCache +} + + +#----------------------------------------------------------------------- +# Component Installation + +# Implements %TYPE%::installhull. The variables self and selfns +# must be defined in the caller's context. +# +# Installs the named widget as the hull of a +# widgetadaptor. Once the widget is hijacked, its new name +# is assigned to the hull component. + +proc ::snit::RT.installhull {type {using "using"} {widgetType ""} args} { + variable ${type}::Snit_info + variable ${type}::Snit_optionInfo + upvar 1 self self + upvar 1 selfns selfns + namespace upvar $selfns \ + hull hull \ + options options + + # FIRST, make sure we can do it. + if {!$Snit_info(isWidget)} { + error "installhull is valid only for snit::widgetadaptors" + } + + if {[info exists ${selfns}::Snit_instance]} { + error "hull already installed for $type $self" + } + + # NEXT, has it been created yet? If not, create it using + # the specified arguments. + if {"using" == $using} { + # FIRST, create the widget + set cmd [linsert $args 0 $widgetType $self] + set obj [uplevel 1 $cmd] + + # NEXT, for each option explicitly delegated to the hull + # that doesn't appear in the usedOpts list, get the + # option database value and apply it--provided that the + # real option name and the target option name are different. + # (If they are the same, then the option database was + # already queried as part of the normal widget creation.) + # + # Also, we don't need to worry about implicitly delegated + # options, as the option and target option names must be + # the same. + if {[info exists Snit_optionInfo(delegated-hull)]} { + + # FIRST, extract all option names from args + set usedOpts {} + set ndx [lsearch -glob $args "-*"] + foreach {opt val} [lrange $args $ndx end] { + lappend usedOpts $opt + } + + foreach opt $Snit_optionInfo(delegated-hull) { + set target [lindex $Snit_optionInfo(target-$opt) 1] + + if {"$target" == $opt} { + continue + } + + set result [lsearch -exact $usedOpts $target] + + if {$result != -1} { + continue + } + + set dbval [RT.OptionDbGet $type $self $opt] + $obj configure $target $dbval + } + } + } else { + set obj $using + + if {$obj ne $self} { + error \ + "hull name mismatch: \"$obj\" != \"$self\"" + } + } + + # NEXT, get the local option defaults. + foreach opt $Snit_optionInfo(local) { + set dbval [RT.OptionDbGet $type $self $opt] + + if {"" != $dbval} { + set options($opt) $dbval + } + } + + + # NEXT, do the magic + set i 0 + while 1 { + incr i + set newName "::hull${i}$self" + if {![llength [info commands $newName]]} { + break + } + } + + rename ::$self $newName + RT.MakeInstanceCommand $type $selfns $self + + # Note: this relies on RT.ComponentTrace to do the dirty work. + set hull $newName + + return +} + +# Implements %TYPE%::install. +# +# Creates a widget and installs it as the named component. +# It expects self and selfns to be defined in the caller's context. + +proc ::snit::RT.install {type compName "using" widgetType winPath args} { + variable ${type}::Snit_optionInfo + variable ${type}::Snit_info + upvar 1 self self + upvar 1 selfns selfns + + namespace upvar ${selfns} \ + $compName comp \ + hull hull + + # We do the magic option database stuff only if $self is + # a widget. + if {$Snit_info(isWidget)} { + if {"" == $hull} { + error "tried to install \"$compName\" before the hull exists" + } + + # FIRST, query the option database and save the results + # into args. Insert them before the first option in the + # list, in case there are any non-standard parameters. + # + # Note: there might not be any delegated options; if so, + # don't bother. + + if {[info exists Snit_optionInfo(delegated-$compName)]} { + set ndx [lsearch -glob $args "-*"] + + foreach opt $Snit_optionInfo(delegated-$compName) { + set dbval [RT.OptionDbGet $type $self $opt] + + if {"" != $dbval} { + set target [lindex $Snit_optionInfo(target-$opt) 1] + set args [linsert $args $ndx $target $dbval] + } + } + } + } + + # NEXT, create the component and save it. + set cmd [concat [list $widgetType $winPath] $args] + set comp [uplevel 1 $cmd] + + # NEXT, handle the option database for "delegate option *", + # in widgets only. + if {$Snit_info(isWidget) && $Snit_optionInfo(starcomp) eq $compName} { + # FIRST, get the list of option specs from the widget. + # If configure doesn't work, skip it. + if {[catch {$comp configure} specs]} { + return + } + + # NEXT, get the set of explicitly used options from args + set usedOpts {} + set ndx [lsearch -glob $args "-*"] + foreach {opt val} [lrange $args $ndx end] { + lappend usedOpts $opt + } + + # NEXT, "delegate option *" matches all options defined + # by this widget that aren't defined by the widget as a whole, + # and that aren't excepted. Plus, we skip usedOpts. So build + # a list of the options it can't match. + set skiplist [concat \ + $usedOpts \ + $Snit_optionInfo(except) \ + $Snit_optionInfo(local) \ + $Snit_optionInfo(delegated)] + + # NEXT, loop over all of the component's options, and set + # any not in the skip list for which there is an option + # database value. + foreach spec $specs { + # Skip aliases + if {[llength $spec] != 5} { + continue + } + + set opt [lindex $spec 0] + + if {[lsearch -exact $skiplist $opt] != -1} { + continue + } + + set res [lindex $spec 1] + set cls [lindex $spec 2] + + set dbvalue [option get $self $res $cls] + + if {"" != $dbvalue} { + $comp configure $opt $dbvalue + } + } + } + + return +} + + +#----------------------------------------------------------------------- +# Method/Variable Name Qualification + +# Implements %TYPE%::variable. Requires selfns. +proc ::snit::RT.variable {varname} { + upvar 1 selfns selfns + + if {![string match "::*" $varname]} { + uplevel 1 [list upvar 1 ${selfns}::$varname $varname] + } else { + # varname is fully qualified; let the standard + # "variable" command handle it. + uplevel 1 [list ::variable $varname] + } +} + +# Fully qualifies a typevariable name. +# +# This is used to implement the mytypevar command. + +proc ::snit::RT.mytypevar {type name} { + return ${type}::$name +} + +# Fully qualifies an instance variable name. +# +# This is used to implement the myvar command. +proc ::snit::RT.myvar {name} { + upvar 1 selfns selfns + return ${selfns}::$name +} + +# Use this like "list" to convert a proc call into a command +# string to pass to another object (e.g., as a -command). +# Qualifies the proc name properly. +# +# This is used to implement the "myproc" command. + +proc ::snit::RT.myproc {type procname args} { + set procname "${type}::$procname" + return [linsert $args 0 $procname] +} + +# DEPRECATED +proc ::snit::RT.codename {type name} { + return "${type}::$name" +} + +# Use this like "list" to convert a typemethod call into a command +# string to pass to another object (e.g., as a -command). +# Inserts the type command at the beginning. +# +# This is used to implement the "mytypemethod" command. + +proc ::snit::RT.mytypemethod {type args} { + return [linsert $args 0 $type] +} + +# Use this like "list" to convert a method call into a command +# string to pass to another object (e.g., as a -command). +# Inserts the code at the beginning to call the right object, even if +# the object's name has changed. Requires that selfns be defined +# in the calling context, eg. can only be called in instance +# code. +# +# This is used to implement the "mymethod" command. + +proc ::snit::RT.mymethod {args} { + upvar 1 selfns selfns + return [linsert $args 0 ::snit::RT.CallInstance ${selfns}] +} + +# Calls an instance method for an object given its +# instance namespace and remaining arguments (the first of which +# will be the method name. +# +# selfns The instance namespace +# args The arguments +# +# Uses the selfns to determine $self, and calls the method +# in the normal way. +# +# This is used to implement the "mymethod" command. + +proc ::snit::RT.CallInstance {selfns args} { + namespace upvar $selfns Snit_instance self + + set retval [catch {uplevel 1 [linsert $args 0 $self]} result] + + if {$retval} { + if {$retval == 1} { + global errorInfo + global errorCode + return -code error -errorinfo $errorInfo \ + -errorcode $errorCode $result + } else { + return -code $retval $result + } + } + + return $result +} + +# Looks for the named option in the named variable. If found, +# it and its value are removed from the list, and the value +# is returned. Otherwise, the default value is returned. +# If the option is undelegated, it's own default value will be +# used if none is specified. +# +# Implements the "from" command. + +proc ::snit::RT.from {type argvName option {defvalue ""}} { + namespace upvar $type Snit_optionInfo Snit_optionInfo + upvar $argvName argv + + set ioption [lsearch -exact $argv $option] + + if {$ioption == -1} { + if {"" == $defvalue && + [info exists Snit_optionInfo(default-$option)]} { + return $Snit_optionInfo(default-$option) + } else { + return $defvalue + } + } + + set ivalue [expr {$ioption + 1}] + set value [lindex $argv $ivalue] + + set argv [lreplace $argv $ioption $ivalue] + + return $value +} + +#----------------------------------------------------------------------- +# Type Destruction + +# Implements the standard "destroy" typemethod: +# Destroys a type completely. +# +# type The snit type + +proc ::snit::RT.typemethod.destroy {type} { + variable ${type}::Snit_info + + # FIRST, destroy all instances + foreach selfns [namespace children $type "${type}::Snit_inst*"] { + if {![namespace exists $selfns]} { + continue + } + + namespace upvar $selfns Snit_instance obj + + if {$Snit_info(isWidget)} { + destroy $obj + } else { + if {[llength [info commands $obj]]} { + $obj destroy + } + } + } + + # NEXT, get rid of the type command. + rename $type "" + + # NEXT, destroy the type's data. + namespace delete $type +} + + + +#----------------------------------------------------------------------- +# Option Handling + +# Implements the standard "cget" method +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# option The name of the option + +proc ::snit::RT.method.cget {type selfns win self option} { + if {[catch {set ${selfns}::Snit_cgetCache($option)} command]} { + set command [snit::RT.CacheCgetCommand $type $selfns $win $self $option] + + if {[llength $command] == 0} { + return -code error "unknown option \"$option\"" + } + } + + uplevel 1 $command +} + +# Retrieves and caches the command that implements "cget" for the +# specified option. +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# option The name of the option + +proc ::snit::RT.CacheCgetCommand {type selfns win self option} { + variable ${type}::Snit_optionInfo + variable ${selfns}::Snit_cgetCache + + if {[info exists Snit_optionInfo(islocal-$option)]} { + # We know the item; it's either local, or explicitly delegated. + if {$Snit_optionInfo(islocal-$option)} { + # It's a local option. If it has a cget method defined, + # use it; otherwise just return the value. + + if {$Snit_optionInfo(cget-$option) eq ""} { + set command [list set ${selfns}::options($option)] + } else { + # WHD: Snit 2.0 code -- simpler, no slower. + set command [list \ + $self \ + {*}$Snit_optionInfo(cget-$option) \ + $option] + } + + set Snit_cgetCache($option) $command + return $command + } + + # Explicitly delegated option; get target + set comp [lindex $Snit_optionInfo(target-$option) 0] + set target [lindex $Snit_optionInfo(target-$option) 1] + } elseif {$Snit_optionInfo(starcomp) ne "" && + [lsearch -exact $Snit_optionInfo(except) $option] == -1} { + # Unknown option, but unknowns are delegated; get target. + set comp $Snit_optionInfo(starcomp) + set target $option + } else { + return "" + } + + # Get the component's object. + set obj [RT.Component $type $selfns $comp] + + set command [list $obj cget $target] + set Snit_cgetCache($option) $command + + return $command +} + +# Implements the standard "configurelist" method +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# optionlist A list of options and their values. + +proc ::snit::RT.method.configurelist {type selfns win self optionlist} { + variable ${type}::Snit_optionInfo + + foreach {option value} $optionlist { + # FIRST, get the configure command, caching it if need be. + if {[catch {set ${selfns}::Snit_configureCache($option)} command]} { + set command [snit::RT.CacheConfigureCommand \ + $type $selfns $win $self $option] + + if {[llength $command] == 0} { + return -code error "unknown option \"$option\"" + } + } + + # NEXT, if we have a type-validation object, use it. + # TBD: Should test (islocal-$option) here, but islocal + # isn't defined for implicitly delegated options. + if {[info exists Snit_optionInfo(typeobj-$option)] + && $Snit_optionInfo(typeobj-$option) ne ""} { + if {[catch { + $Snit_optionInfo(typeobj-$option) validate $value + } result]} { + return -code error "invalid $option value: $result" + } + } + + # NEXT, the caching the configure command also cached the + # validate command, if any. If we have one, run it. + set valcommand [set ${selfns}::Snit_validateCache($option)] + + if {[llength $valcommand]} { + lappend valcommand $value + uplevel 1 $valcommand + } + + # NEXT, configure the option with the value. + lappend command $value + uplevel 1 $command + } + + return +} + +# Retrieves and caches the command that stores the named option. +# Also stores the command that validates the name option if any; +# If none, the validate command is "", so that the cache is always +# populated. +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# option An option name + +proc ::snit::RT.CacheConfigureCommand {type selfns win self option} { + variable ${type}::Snit_optionInfo + variable ${selfns}::Snit_configureCache + variable ${selfns}::Snit_validateCache + + if {[info exist Snit_optionInfo(islocal-$option)]} { + # We know the item; it's either local, or explicitly delegated. + + if {$Snit_optionInfo(islocal-$option)} { + # It's a local option. + + # If it's readonly, it throws an error if we're already + # constructed. + if {$Snit_optionInfo(readonly-$option)} { + if {[set ${selfns}::Snit_iinfo(constructed)]} { + error "option $option can only be set at instance creation" + } + } + + # If it has a validate method, cache that for later. + if {$Snit_optionInfo(validate-$option) ne ""} { + # WHD: Snit 2.0 code -- simpler, no slower. + set command [list \ + $self \ + {*}$Snit_optionInfo(validate-$option) \ + $option] + + set Snit_validateCache($option) $command + } else { + set Snit_validateCache($option) "" + } + + # If it has a configure method defined, + # cache it; otherwise, just set the value. + if {$Snit_optionInfo(configure-$option) eq ""} { + set command [list set ${selfns}::options($option)] + } else { + # WHD: Snit 2.0 code -- simpler, no slower. + set command [list \ + $self \ + {*}$Snit_optionInfo(configure-$option) \ + $option] + } + + set Snit_configureCache($option) $command + return $command + } + + # Delegated option: get target. + set comp [lindex $Snit_optionInfo(target-$option) 0] + set target [lindex $Snit_optionInfo(target-$option) 1] + } elseif {$Snit_optionInfo(starcomp) != "" && + [lsearch -exact $Snit_optionInfo(except) $option] == -1} { + # Unknown option, but unknowns are delegated. + set comp $Snit_optionInfo(starcomp) + set target $option + } else { + return "" + } + + # There is no validate command in this case; save an empty string. + set Snit_validateCache($option) "" + + # Get the component's object + set obj [RT.Component $type $selfns $comp] + + set command [list $obj configure $target] + set Snit_configureCache($option) $command + + return $command +} + +# Implements the standard "configure" method +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# args A list of options and their values, possibly empty. + +proc ::snit::RT.method.configure {type selfns win self args} { + # If two or more arguments, set values as usual. + if {[llength $args] >= 2} { + ::snit::RT.method.configurelist $type $selfns $win $self $args + return + } + + # If zero arguments, acquire data for each known option + # and return the list + if {[llength $args] == 0} { + set result {} + foreach opt [RT.method.info.options $type $selfns $win $self] { + # Refactor this, so that we don't need to call via $self. + lappend result [RT.GetOptionDbSpec \ + $type $selfns $win $self $opt] + } + + return $result + } + + # They want it for just one. + set opt [lindex $args 0] + + return [RT.GetOptionDbSpec $type $selfns $win $self $opt] +} + + +# Retrieves the option database spec for a single option. +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# option The name of an option +# +# TBD: This is a bad name. What it's returning is the +# result of the configure query. + +proc ::snit::RT.GetOptionDbSpec {type selfns win self opt} { + variable ${type}::Snit_optionInfo + + namespace upvar $selfns \ + Snit_components Snit_components \ + options options + + if {[info exists options($opt)]} { + # This is a locally-defined option. Just build the + # list and return it. + set res $Snit_optionInfo(resource-$opt) + set cls $Snit_optionInfo(class-$opt) + set def $Snit_optionInfo(default-$opt) + + return [list $opt $res $cls $def \ + [RT.method.cget $type $selfns $win $self $opt]] + } elseif {[info exists Snit_optionInfo(target-$opt)]} { + # This is an explicitly delegated option. The only + # thing we don't have is the default. + set res $Snit_optionInfo(resource-$opt) + set cls $Snit_optionInfo(class-$opt) + + # Get the default + set logicalName [lindex $Snit_optionInfo(target-$opt) 0] + set comp $Snit_components($logicalName) + set target [lindex $Snit_optionInfo(target-$opt) 1] + + if {[catch {$comp configure $target} result]} { + set defValue {} + } else { + set defValue [lindex $result 3] + } + + return [list $opt $res $cls $defValue [$self cget $opt]] + } elseif {$Snit_optionInfo(starcomp) ne "" && + [lsearch -exact $Snit_optionInfo(except) $opt] == -1} { + set logicalName $Snit_optionInfo(starcomp) + set target $opt + set comp $Snit_components($logicalName) + + if {[catch {set value [$comp cget $target]} result]} { + error "unknown option \"$opt\"" + } + + if {![catch {$comp configure $target} result]} { + # Replace the delegated option name with the local name. + return [::snit::Expand $result $target $opt] + } + + # configure didn't work; return simple form. + return [list $opt "" "" "" $value] + } else { + error "unknown option \"$opt\"" + } +} + +#----------------------------------------------------------------------- +# Type Introspection + +# Implements the standard "info" typemethod. +# +# type The snit type +# command The info subcommand +# args All other arguments. + +proc ::snit::RT.typemethod.info {type command args} { + global errorInfo + global errorCode + + switch -exact $command { + args - + body - + default - + typevars - + typemethods - + instances { + # TBD: it should be possible to delete this error + # handling. + set errflag [catch { + uplevel 1 [linsert $args 0 \ + ::snit::RT.typemethod.info.$command $type] + } result] + + if {$errflag} { + return -code error -errorinfo $errorInfo \ + -errorcode $errorCode $result + } else { + return $result + } + } + default { + error "\"$type info $command\" is not defined" + } + } +} + + +# Returns a list of the type's typevariables whose names match a +# pattern, excluding Snit internal variables. +# +# type A Snit type +# pattern Optional. The glob pattern to match. Defaults +# to *. + +proc ::snit::RT.typemethod.info.typevars {type {pattern *}} { + set result {} + foreach name [info vars "${type}::$pattern"] { + set tail [namespace tail $name] + if {![string match "Snit_*" $tail]} { + lappend result $name + } + } + + return $result +} + +# Returns a list of the type's methods whose names match a +# pattern. If "delegate typemethod *" is used, the list may +# not be complete. +# +# type A Snit type +# pattern Optional. The glob pattern to match. Defaults +# to *. + +proc ::snit::RT.typemethod.info.typemethods {type {pattern *}} { + variable ${type}::Snit_typemethodInfo + + # FIRST, get the explicit names, skipping prefixes. + set result {} + + foreach name [array names Snit_typemethodInfo -glob $pattern] { + if {[lindex $Snit_typemethodInfo($name) 0] != 1} { + lappend result $name + } + } + + # NEXT, add any from the cache that aren't explicit. + # WHD: fixed up to use newstyle method cache/list of subcommands. + if {[info exists Snit_typemethodInfo(*)]} { + # First, remove "*" from the list. + set ndx [lsearch -exact $result "*"] + if {$ndx != -1} { + set result [lreplace $result $ndx $ndx] + } + + # Next, get the type's -map + array set typemethodCache [namespace ensemble configure $type -map] + + # Next, get matching names from the cache that we don't already + # know about. + foreach name [array names typemethodCache -glob $pattern] { + if {[lsearch -exact $result $name] == -1} { + lappend result $name + } + } + } + + return $result +} + +# $type info args +# +# Returns a method's list of arguments. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.typemethod.info.args {type method} { + upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_typemethodInfo + + if {![info exists Snit_typemethodInfo($method)]} { + return -code error "Unknown typemethod \"$method\"" + } + foreach {flag cmd component} $Snit_typemethodInfo($method) break + if {$flag} { + return -code error "Unknown typemethod \"$method\"" + } + if {$component != ""} { + return -code error "Delegated typemethod \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type] + set theproc [lindex [string map $map $cmd] 0] + return [lrange [::info args $theproc] 1 end] +} + +# $type info body +# +# Returns a method's body. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.typemethod.info.body {type method} { + upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_typemethodInfo + + if {![info exists Snit_typemethodInfo($method)]} { + return -code error "Unknown typemethod \"$method\"" + } + foreach {flag cmd component} $Snit_typemethodInfo($method) break + if {$flag} { + return -code error "Unknown typemethod \"$method\"" + } + if {$component != ""} { + return -code error "Delegated typemethod \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type] + set theproc [lindex [string map $map $cmd] 0] + return [RT.body [::info body $theproc]] +} + +# $type info default +# +# Returns a method's list of arguments. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.typemethod.info.default {type method aname dvar} { + upvar 1 $dvar def + upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_methodInfo + + if {![info exists Snit_typemethodInfo($method)]} { + return -code error "Unknown typemethod \"$method\"" + } + foreach {flag cmd component} $Snit_typemethodInfo($method) break + if {$flag} { + return -code error "Unknown typemethod \"$method\"" + } + if {$component != ""} { + return -code error "Delegated typemethod \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type] + set theproc [lindex [string map $map $cmd] 0] + return [::info default $theproc $aname def] +} + +# Returns a list of the type's instances whose names match +# a pattern. +# +# type A Snit type +# pattern Optional. The glob pattern to match +# Defaults to * +# +# REQUIRE: type is fully qualified. + +proc ::snit::RT.typemethod.info.instances {type {pattern *}} { + set result {} + + foreach selfns [namespace children $type "${type}::Snit_inst*"] { + namespace upvar $selfns Snit_instance instance + + if {[string match $pattern $instance]} { + lappend result $instance + } + } + + return $result +} + +#----------------------------------------------------------------------- +# Instance Introspection + +# Implements the standard "info" method. +# +# type The snit type +# selfns The instance's instance namespace +# win The instance's original name +# self The instance's current name +# command The info subcommand +# args All other arguments. + +proc ::snit::RT.method.info {type selfns win self command args} { + switch -exact $command { + args - + body - + default - + type - + vars - + options - + methods - + typevars - + typemethods { + set errflag [catch { + uplevel 1 [linsert $args 0 ::snit::RT.method.info.$command \ + $type $selfns $win $self] + } result] + + if {$errflag} { + global errorInfo + return -code error -errorinfo $errorInfo $result + } else { + return $result + } + } + default { + # error "\"$self info $command\" is not defined" + return -code error "\"$self info $command\" is not defined" + } + } +} + +# $self info type +# +# Returns the instance's type +proc ::snit::RT.method.info.type {type selfns win self} { + return $type +} + +# $self info typevars +# +# Returns the instance's type's typevariables +proc ::snit::RT.method.info.typevars {type selfns win self {pattern *}} { + return [RT.typemethod.info.typevars $type $pattern] +} + +# $self info typemethods +# +# Returns the instance's type's typemethods +proc ::snit::RT.method.info.typemethods {type selfns win self {pattern *}} { + return [RT.typemethod.info.typemethods $type $pattern] +} + +# Returns a list of the instance's methods whose names match a +# pattern. If "delegate method *" is used, the list may +# not be complete. +# +# type A Snit type +# selfns The instance namespace +# win The original instance name +# self The current instance name +# pattern Optional. The glob pattern to match. Defaults +# to *. + +proc ::snit::RT.method.info.methods {type selfns win self {pattern *}} { + variable ${type}::Snit_methodInfo + + # FIRST, get the explicit names, skipping prefixes. + set result {} + + foreach name [array names Snit_methodInfo -glob $pattern] { + if {[lindex $Snit_methodInfo($name) 0] != 1} { + lappend result $name + } + } + + # NEXT, add any from the cache that aren't explicit. + # WHD: Fixed up to use newstyle method cache/list of subcommands. + if {[info exists Snit_methodInfo(*)]} { + # First, remove "*" from the list. + set ndx [lsearch -exact $result "*"] + if {$ndx != -1} { + set result [lreplace $result $ndx $ndx] + } + + # Next, get the instance's -map + set self [set ${selfns}::Snit_instance] + + array set methodCache [namespace ensemble configure $self -map] + + # Next, get matching names from the cache that we don't already + # know about. + foreach name [array names methodCache -glob $pattern] { + if {[lsearch -exact $result $name] == -1} { + lappend result $name + } + } + } + + return $result +} + +# $self info args +# +# Returns a method's list of arguments. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.method.info.args {type selfns win self method} { + + upvar ${type}::Snit_methodInfo Snit_methodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_methodInfo + + if {![info exists Snit_methodInfo($method)]} { + return -code error "Unknown method \"$method\"" + } + foreach {flag cmd component} $Snit_methodInfo($method) break + if {$flag} { + return -code error "Unknown method \"$method\"" + } + if {$component != ""} { + return -code error "Delegated method \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] + set theproc [lindex [string map $map $cmd] 0] + return [lrange [::info args $theproc] 4 end] +} + +# $self info body +# +# Returns a method's body. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.method.info.body {type selfns win self method} { + + upvar ${type}::Snit_methodInfo Snit_methodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + #parray Snit_methodInfo + + if {![info exists Snit_methodInfo($method)]} { + return -code error "Unknown method \"$method\"" + } + foreach {flag cmd component} $Snit_methodInfo($method) break + if {$flag} { + return -code error "Unknown method \"$method\"" + } + if {$component != ""} { + return -code error "Delegated method \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] + set theproc [lindex [string map $map $cmd] 0] + return [RT.body [::info body $theproc]] +} + +# $self info default +# +# Returns a method's list of arguments. does not work for delegated +# methods, nor for the internal dispatch methods of multi-word +# methods. + +proc ::snit::RT.method.info.default {type selfns win self method aname dvar} { + upvar 1 $dvar def + upvar ${type}::Snit_methodInfo Snit_methodInfo + + # Snit_methodInfo: method -> list (flag cmd component) + + # flag : 1 -> internal dispatcher for multi-word method. + # 0 -> regular method + # + # cmd : template mapping from method to command prefix, may + # contain placeholders for various pieces of information. + # + # component : is empty for normal methods. + + if {![info exists Snit_methodInfo($method)]} { + return -code error "Unknown method \"$method\"" + } + foreach {flag cmd component} $Snit_methodInfo($method) break + if {$flag} { + return -code error "Unknown method \"$method\"" + } + if {$component != ""} { + return -code error "Delegated method \"$method\"" + } + + set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] + set theproc [lindex [string map $map $cmd] 0] + return [::info default $theproc $aname def] +} + +# $self info vars +# +# Returns the instance's instance variables +proc ::snit::RT.method.info.vars {type selfns win self {pattern *}} { + set result {} + foreach name [info vars "${selfns}::$pattern"] { + set tail [namespace tail $name] + if {![string match "Snit_*" $tail]} { + lappend result $name + } + } + + return $result +} + +# $self info options +# +# Returns a list of the names of the instance's options +proc ::snit::RT.method.info.options {type selfns win self {pattern *}} { + variable ${type}::Snit_optionInfo + + # First, get the local and explicitly delegated options + set result [concat $Snit_optionInfo(local) $Snit_optionInfo(delegated)] + + # If "configure" works as for Tk widgets, add the resulting + # options to the list. Skip excepted options + if {$Snit_optionInfo(starcomp) ne ""} { + namespace upvar $selfns Snit_components Snit_components + + set logicalName $Snit_optionInfo(starcomp) + set comp $Snit_components($logicalName) + + if {![catch {$comp configure} records]} { + foreach record $records { + set opt [lindex $record 0] + if {[lsearch -exact $result $opt] == -1 && + [lsearch -exact $Snit_optionInfo(except) $opt] == -1} { + lappend result $opt + } + } + } + } + + # Next, apply the pattern + set names {} + + foreach name $result { + if {[string match $pattern $name]} { + lappend names $name + } + } + + return $names +} + +proc ::snit::RT.body {body} { + regsub -all ".*# END snit method prolog\n" $body {} body + return $body +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/pkgIndex.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/pkgIndex.tcl new file mode 100644 index 00000000..a6624b25 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/pkgIndex.tcl @@ -0,0 +1,6 @@ +if {[package vsatisfies [package provide Tcl] 8.5 9]} { + package ifneeded snit 2.3.3 \ + [list source [file join $dir snit2.tcl]] +} + +package ifneeded snit 1.4.2 [list source [file join $dir snit.tcl]] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/snit.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/snit.tcl new file mode 100644 index 00000000..20f6a40f --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/snit.tcl @@ -0,0 +1,32 @@ +#----------------------------------------------------------------------- +# TITLE: +# snit.tcl +# +# AUTHOR: +# Will Duquette +# +# DESCRIPTION: +# Snit's Not Incr Tcl, a simple object system in Pure Tcl. +# +# Snit 1.x Loader +# +# Copyright (C) 2003-2006 by William H. Duquette +# This code is licensed as described in license.txt. +# +#----------------------------------------------------------------------- + +package require Tcl 8.5 9 + +# Define the snit namespace and save the library directory + +namespace eval ::snit:: { + set library [file dirname [info script]] +} + +source [file join $::snit::library main1.tcl] + +# Load the library of Snit validation types. + +source [file join $::snit::library validate.tcl] + +package provide snit 1.4.2 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/snit2.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/snit2.tcl new file mode 100644 index 00000000..b7675a58 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/snit2.tcl @@ -0,0 +1,32 @@ +#----------------------------------------------------------------------- +# TITLE: +# snit2.tcl +# +# AUTHOR: +# Will Duquette +# +# DESCRIPTION: +# Snit's Not Incr Tcl, a simple object system in Pure Tcl. +# +# Snit 2.x Loader +# +# Copyright (C) 2003-2006 by William H. Duquette +# This code is licensed as described in license.txt. +# +#----------------------------------------------------------------------- + +package require Tcl 8.5 9 + +# Define the snit namespace and save the library directory + +namespace eval ::snit:: { + set library [file dirname [info script]] +} + +# Load the kernel. +source [file join $::snit::library main2.tcl] + +# Load the library of Snit validation types. +source [file join $::snit::library validate.tcl] + +package provide snit 2.3.3 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/validate.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/validate.tcl new file mode 100644 index 00000000..4275e9be --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/snit/validate.tcl @@ -0,0 +1,720 @@ +#----------------------------------------------------------------------- +# TITLE: +# validate.tcl +# +# AUTHOR: +# Will Duquette +# +# DESCRIPTION: +# Snit validation types. +# +#----------------------------------------------------------------------- + +namespace eval ::snit:: { + namespace export \ + boolean \ + double \ + enum \ + fpixels \ + integer \ + listtype \ + pixels \ + stringtype \ + window +} + +#----------------------------------------------------------------------- +# snit::boolean + +snit::type ::snit::boolean { + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + if {![string is boolean -strict $value]} { + return -code error -errorcode INVALID \ + "invalid boolean \"$value\", should be one of: 1, 0, true, false, yes, no, on, off" + + } + + return $value + } + + #------------------------------------------------------------------- + # Constructor + + # None needed; no options + + #------------------------------------------------------------------- + # Public Methods + + method validate {value} { + $type validate $value + } +} + +#----------------------------------------------------------------------- +# snit::double + +snit::type ::snit::double { + #------------------------------------------------------------------- + # Options + + # -min value + # + # Minimum value + + option -min -default "" -readonly 1 + + # -max value + # + # Maximum value + + option -max -default "" -readonly 1 + + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + if {![string is double -strict $value]} { + return -code error -errorcode INVALID \ + "invalid value \"$value\", expected double" + } + + return $value + } + + #------------------------------------------------------------------- + # Constructor + + constructor {args} { + # FIRST, get the options + $self configurelist $args + + if {"" != $options(-min) && + ![string is double -strict $options(-min)]} { + return -code error \ + "invalid -min: \"$options(-min)\"" + } + + if {"" != $options(-max) && + ![string is double -strict $options(-max)]} { + return -code error \ + "invalid -max: \"$options(-max)\"" + } + + if {"" != $options(-min) && + "" != $options(-max) && + $options(-max) < $options(-min)} { + return -code error "-max < -min" + } + } + + #------------------------------------------------------------------- + # Public Methods + + # Fixed method for the snit::double type. + # WHD, 6/7/2010. + method validate {value} { + $type validate $value + + if {("" != $options(-min) && $value < $options(-min)) || + ("" != $options(-max) && $value > $options(-max))} { + + set msg "invalid value \"$value\", expected double" + + if {"" != $options(-min) && "" != $options(-max)} { + append msg " in range $options(-min), $options(-max)" + } elseif {"" != $options(-min)} { + append msg " no less than $options(-min)" + } elseif {"" != $options(-max)} { + append msg " no greater than $options(-max)" + } + + return -code error -errorcode INVALID $msg + } + + return $value + } +} + +#----------------------------------------------------------------------- +# snit::enum + +snit::type ::snit::enum { + #------------------------------------------------------------------- + # Options + + # -values list + # + # Valid values for this type + + option -values -default {} -readonly 1 + + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + # No -values specified; it's always valid + return $value + } + + #------------------------------------------------------------------- + # Constructor + + constructor {args} { + $self configurelist $args + + if {[llength $options(-values)] == 0} { + return -code error \ + "invalid -values: \"\"" + } + } + + #------------------------------------------------------------------- + # Public Methods + + method validate {value} { + if {[lsearch -exact $options(-values) $value] == -1} { + return -code error -errorcode INVALID \ + "invalid value \"$value\", should be one of: [join $options(-values) {, }]" + } + + return $value + } +} + +#----------------------------------------------------------------------- +# snit::fpixels + +snit::type ::snit::fpixels { + #------------------------------------------------------------------- + # Options + + # -min value + # + # Minimum value + + option -min -default "" -readonly 1 + + # -max value + # + # Maximum value + + option -max -default "" -readonly 1 + + #------------------------------------------------------------------- + # Instance variables + + variable min "" ;# -min, no suffix + variable max "" ;# -max, no suffix + + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + if {[catch {winfo fpixels . $value} dummy]} { + return -code error -errorcode INVALID \ + "invalid value \"$value\", expected fpixels" + } + + return $value + } + + #------------------------------------------------------------------- + # Constructor + + constructor {args} { + # FIRST, get the options + $self configurelist $args + + if {"" != $options(-min) && + [catch {winfo fpixels . $options(-min)} min]} { + return -code error \ + "invalid -min: \"$options(-min)\"" + } + + if {"" != $options(-max) && + [catch {winfo fpixels . $options(-max)} max]} { + return -code error \ + "invalid -max: \"$options(-max)\"" + } + + if {"" != $min && + "" != $max && + $max < $min} { + return -code error "-max < -min" + } + } + + #------------------------------------------------------------------- + # Public Methods + + method validate {value} { + $type validate $value + + set val [winfo fpixels . $value] + + if {("" != $min && $val < $min) || + ("" != $max && $val > $max)} { + + set msg "invalid value \"$value\", expected fpixels" + + if {"" != $min && "" != $max} { + append msg " in range $options(-min), $options(-max)" + } elseif {"" != $min} { + append msg " no less than $options(-min)" + } + + return -code error -errorcode INVALID $msg + } + + return $value + } +} + +#----------------------------------------------------------------------- +# snit::integer + +snit::type ::snit::integer { + #------------------------------------------------------------------- + # Options + + # -min value + # + # Minimum value + + option -min -default "" -readonly 1 + + # -max value + # + # Maximum value + + option -max -default "" -readonly 1 + + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + if {![string is integer -strict $value]} { + return -code error -errorcode INVALID \ + "invalid value \"$value\", expected integer" + } + + return $value + } + + #------------------------------------------------------------------- + # Constructor + + constructor {args} { + # FIRST, get the options + $self configurelist $args + + if {"" != $options(-min) && + ![string is integer -strict $options(-min)]} { + return -code error \ + "invalid -min: \"$options(-min)\"" + } + + if {"" != $options(-max) && + ![string is integer -strict $options(-max)]} { + return -code error \ + "invalid -max: \"$options(-max)\"" + } + + if {"" != $options(-min) && + "" != $options(-max) && + $options(-max) < $options(-min)} { + return -code error "-max < -min" + } + } + + #------------------------------------------------------------------- + # Public Methods + + method validate {value} { + $type validate $value + + if {("" != $options(-min) && $value < $options(-min)) || + ("" != $options(-max) && $value > $options(-max))} { + + set msg "invalid value \"$value\", expected integer" + + if {"" != $options(-min) && "" != $options(-max)} { + append msg " in range $options(-min), $options(-max)" + } elseif {"" != $options(-min)} { + append msg " no less than $options(-min)" + } + + return -code error -errorcode INVALID $msg + } + + return $value + } +} + +#----------------------------------------------------------------------- +# snit::list + +snit::type ::snit::listtype { + #------------------------------------------------------------------- + # Options + + # -type type + # + # Specifies a value type + + option -type -readonly 1 + + # -minlen len + # + # Minimum list length + + option -minlen -readonly 1 -default 0 + + # -maxlen len + # + # Maximum list length + + option -maxlen -readonly 1 + + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + if {[catch {llength $value} result]} { + return -code error -errorcode INVALID \ + "invalid value \"$value\", expected list" + } + + return $value + } + + #------------------------------------------------------------------- + # Constructor + + constructor {args} { + # FIRST, get the options + $self configurelist $args + + if {"" != $options(-minlen) && + (![string is integer -strict $options(-minlen)] || + $options(-minlen) < 0)} { + return -code error \ + "invalid -minlen: \"$options(-minlen)\"" + } + + if {"" == $options(-minlen)} { + set options(-minlen) 0 + } + + if {"" != $options(-maxlen) && + ![string is integer -strict $options(-maxlen)]} { + return -code error \ + "invalid -maxlen: \"$options(-maxlen)\"" + } + + if {"" != $options(-maxlen) && + $options(-maxlen) < $options(-minlen)} { + return -code error "-maxlen < -minlen" + } + } + + + #------------------------------------------------------------------- + # Methods + + method validate {value} { + $type validate $value + + set len [llength $value] + + if {$len < $options(-minlen)} { + return -code error -errorcode INVALID \ + "value has too few elements; at least $options(-minlen) expected" + } elseif {"" != $options(-maxlen)} { + if {$len > $options(-maxlen)} { + return -code error -errorcode INVALID \ + "value has too many elements; no more than $options(-maxlen) expected" + } + } + + # NEXT, check each value + if {"" != $options(-type)} { + foreach item $value { + set cmd $options(-type) + lappend cmd validate $item + uplevel \#0 $cmd + } + } + + return $value + } +} + +#----------------------------------------------------------------------- +# snit::pixels + +snit::type ::snit::pixels { + #------------------------------------------------------------------- + # Options + + # -min value + # + # Minimum value + + option -min -default "" -readonly 1 + + # -max value + # + # Maximum value + + option -max -default "" -readonly 1 + + #------------------------------------------------------------------- + # Instance variables + + variable min "" ;# -min, no suffix + variable max "" ;# -max, no suffix + + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + if {[catch {winfo pixels . $value} dummy]} { + return -code error -errorcode INVALID \ + "invalid value \"$value\", expected pixels" + } + + return $value + } + + #------------------------------------------------------------------- + # Constructor + + constructor {args} { + # FIRST, get the options + $self configurelist $args + + if {"" != $options(-min) && + [catch {winfo pixels . $options(-min)} min]} { + return -code error \ + "invalid -min: \"$options(-min)\"" + } + + if {"" != $options(-max) && + [catch {winfo pixels . $options(-max)} max]} { + return -code error \ + "invalid -max: \"$options(-max)\"" + } + + if {"" != $min && + "" != $max && + $max < $min} { + return -code error "-max < -min" + } + } + + #------------------------------------------------------------------- + # Public Methods + + method validate {value} { + $type validate $value + + set val [winfo pixels . $value] + + if {("" != $min && $val < $min) || + ("" != $max && $val > $max)} { + + set msg "invalid value \"$value\", expected pixels" + + if {"" != $min && "" != $max} { + append msg " in range $options(-min), $options(-max)" + } elseif {"" != $min} { + append msg " no less than $options(-min)" + } + + return -code error -errorcode INVALID $msg + } + + return $value + } +} + +#----------------------------------------------------------------------- +# snit::stringtype + +snit::type ::snit::stringtype { + #------------------------------------------------------------------- + # Options + + # -minlen len + # + # Minimum list length + + option -minlen -readonly 1 -default 0 + + # -maxlen len + # + # Maximum list length + + option -maxlen -readonly 1 + + # -nocase 0|1 + # + # globs and regexps are case-insensitive if -nocase 1. + + option -nocase -readonly 1 -default 0 + + # -glob pattern + # + # Glob-match pattern, or "" + + option -glob -readonly 1 + + # -regexp regexp + # + # Regular expression to match + + option -regexp -readonly 1 + + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + # By default, any string (hence, any Tcl value) is valid. + return $value + } + + #------------------------------------------------------------------- + # Constructor + + constructor {args} { + # FIRST, get the options + $self configurelist $args + + # NEXT, validate -minlen and -maxlen + if {"" != $options(-minlen) && + (![string is integer -strict $options(-minlen)] || + $options(-minlen) < 0)} { + return -code error \ + "invalid -minlen: \"$options(-minlen)\"" + } + + if {"" == $options(-minlen)} { + set options(-minlen) 0 + } + + if {"" != $options(-maxlen) && + ![string is integer -strict $options(-maxlen)]} { + return -code error \ + "invalid -maxlen: \"$options(-maxlen)\"" + } + + if {"" != $options(-maxlen) && + $options(-maxlen) < $options(-minlen)} { + return -code error "-maxlen < -minlen" + } + + # NEXT, validate -nocase + if {[catch {snit::boolean validate $options(-nocase)} result]} { + return -code error "invalid -nocase: $result" + } + + # Validate the glob + if {"" != $options(-glob) && + [catch {string match $options(-glob) ""} dummy]} { + return -code error \ + "invalid -glob: \"$options(-glob)\"" + } + + # Validate the regexp + if {"" != $options(-regexp) && + [catch {regexp $options(-regexp) ""} dummy]} { + return -code error \ + "invalid -regexp: \"$options(-regexp)\"" + } + } + + + #------------------------------------------------------------------- + # Methods + + method validate {value} { + # Usually we'd call [$type validate $value] here, but + # as it's a no-op, don't bother. + + # FIRST, validate the length. + set len [string length $value] + + if {$len < $options(-minlen)} { + return -code error -errorcode INVALID \ + "too short: at least $options(-minlen) characters expected" + } elseif {"" != $options(-maxlen)} { + if {$len > $options(-maxlen)} { + return -code error -errorcode INVALID \ + "too long: no more than $options(-maxlen) characters expected" + } + } + + # NEXT, check the glob match, with or without case. + if {"" != $options(-glob)} { + if {$options(-nocase)} { + set result [string match -nocase $options(-glob) $value] + } else { + set result [string match $options(-glob) $value] + } + + if {!$result} { + return -code error -errorcode INVALID \ + "invalid value \"$value\"" + } + } + + # NEXT, check regexp match with or without case + if {"" != $options(-regexp)} { + if {$options(-nocase)} { + set result [regexp -nocase -- $options(-regexp) $value] + } else { + set result [regexp -- $options(-regexp) $value] + } + + if {!$result} { + return -code error -errorcode INVALID \ + "invalid value \"$value\"" + } + } + + return $value + } +} + +#----------------------------------------------------------------------- +# snit::window + +snit::type ::snit::window { + #------------------------------------------------------------------- + # Type Methods + + typemethod validate {value} { + if {![winfo exists $value]} { + return -code error -errorcode INVALID \ + "invalid value \"$value\", value is not a window" + } + + return $value + } + + #------------------------------------------------------------------- + # Constructor + + # None needed; no options + + #------------------------------------------------------------------- + # Public Methods + + method validate {value} { + $type validate $value + } +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/disjointset.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/disjointset.tcl new file mode 100644 index 00000000..677fa66d --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/disjointset.tcl @@ -0,0 +1,385 @@ +# disjointset.tcl -- +# +# Implementation of a Disjoint Set for Tcl. +# +# Copyright (c) Google Summer of Code 2008 Alejandro Eduardo Cruz Paz +# Copyright (c) 2008 Andreas Kupries (API redesign and simplification) +# Copyright (c) 2018 by Kevin B. Kenny - reworked to a proper disjoint-sets +# data structure, added 'add-element', 'exemplars' and 'find-exemplar'. + +# References +# +# - General overview +# - https://en.wikipedia.org/wiki/Disjoint-set_data_structure +# +# - Time/Complexity proofs +# - https://dl.acm.org/citation.cfm?doid=62.2160 +# - https://dl.acm.org/citation.cfm?doid=364099.364331 +# + +package require Tcl 8.6 9 + +# Initialize the disjointset structure namespace. Note that any +# missing parent namespace (::struct) will be automatically created as +# well. +namespace eval ::struct::disjointset { + + # Only export one command, the one used to instantiate a new + # disjoint set + namespace export disjointset +} + +# class struct::disjointset::_disjointset -- +# +# Implementation of a disjoint-sets data structure + +oo::class create struct::disjointset::_disjointset { + + # elements - Dictionary whose keys are all the elements in the structure, + # and whose values are element numbers. + # tree - List indexed by element number whose members are + # ordered triples consisting of the element's name, + # the element number of the element's parent (or the element's + # own index if the element is a root), and the rank of + # the element. + # nParts - Number of partitions in the structure. Maintained only + # so that num_partitions will work. + + variable elements tree nParts + + constructor {} { + set elements {} + set tree {} + set nParts 0 + } + + # add-element -- + # + # Adds an element to the structure + # + # Parameters: + # item - Name of the element to add + # + # Results: + # None. + # + # Side effects: + # Element is added + + method add-element {item} { + if {[dict exists $elements $item]} { + return -code error \ + -errorcode [list STRUCT DISJOINTSET DUPLICATE $item [self]] \ + "The element \"$item\" is already known to the disjoint\ + set [self]" + } + set n [llength $tree] + dict set elements $item $n + lappend tree [list $item $n 0] + incr nParts + return + } + + # add-partition -- + # + # Adds a collection of new elements to a disjoint-sets structure and + # makes them all one partition. + # + # Parameters: + # items - List of elements to add. + # + # Results: + # None. + # + # Side effects: + # Adds all the elements, and groups them into a single partition. + + method add-partition {items} { + + # Integrity check - make sure that none of the elements have yet + # been added + + foreach name $items { + if {[dict exists $elements $name]} { + return -code error \ + -errorcode [list STRUCT DISJOINTSET DUPLICATE \ + $name [self]] \ + "The element \"$name\" is already known to the disjoint\ + set [self]" + } + } + + # Add all the elements in one go, and establish parent links for all + # but the first + + set first -1 + foreach n $items { + set idx [llength $tree] + dict set elements $n $idx + if {$first < 0} { + set first $idx + set rank 1 + } else { + set rank 0 + } + lappend tree [list $n $first $rank] + } + incr nParts + return + } + + # equal -- + # + # Test if two elements belong to the same partition in a disjoint-sets + # data structure. + # + # Parameters: + # a - Name of the first element + # b - Name of the second element + # + # Results: + # Returns 1 if the elements are in the same partition, and 0 otherwise. + + method equal {a b} { + expr {[my FindNum $a] == [my FindNum $b]} + } + + # exemplars -- + # + # Find one representative element for each partition in a disjoint-sets + # data structure. + # + # Results: + # Returns a list of element names + + method exemplars {} { + set result {} + set n -1 + foreach row $tree { + if {[lindex $row 1] == [incr n]} { + lappend result [lindex $row 0] + } + } + return $result + } + + # find -- + # + # Find the partition to which a given element belongs. + # + # Parameters: + # item - Item to find + # + # Results: + # Returns a list of the partition's members + # + # Notes: + # This operation takes time proportional to the total number of elements + # in the disjoint-sets structure. If a simple name of the partition + # is all that is required, use "find-exemplar" instead, which runs + # in amortized time proportional to the inverse Ackermann function of + # the size of the partition. + + method find {item} { + set result {} + # No error on a nonexistent item + if {![dict exists $elements $item]} { + return {} + } + set pnum [my FindNum $item] + set n -1 + foreach row $tree { + if {[my FindByNum [incr n]] eq $pnum} { + lappend result [lindex $row 0] + } + } + return $result + } + + # find-exemplar -- + # + # Find a representative element of the partition that contains a given + # element. + # + # parameters: + # item - Item to examine + # + # Results: + # Returns the exemplar + # + # Notes: + # Takes O(alpha(|P|)) amortized time, where |P| is the size of the + # partition, and alpha is the inverse Ackermann function + + method find-exemplar {item} { + return [lindex $tree [my FindNum $item] 0] + } + + # merge -- + # + # Merges the partitions that two elements are in. + # + # Results: + # None. + + method merge {a b} { + my MergeByNum [my FindNum $a] [my FindNum $b] + } + + # num-partitions -- + # + # Counts the partitions of a disjoint-sets data structure + # + # Results: + # Returns the partition count. + + method num-partitions {} { + return $nParts + } + + # partitions -- + # + # Enumerates the partitions of a disjoint-sets data structure + # + # Results: + # Returns a list of lists. Each list is one of the partitions + # in the disjoint set, and each member of the sublist is one + # of the elements added to the structure. + + method partitions {} { + + # Find the partition number for each element, and accumulate a + # list per partition + set parts {} + dict for {element eltNo} $elements { + set partNo [my FindByNum $eltNo] + dict lappend parts $partNo $element + } + return [dict values $parts] + } + + # FindNum -- + # + # Finds the partition number for an element. + # + # Parameters: + # item - Item to look up + # + # Results: + # Returns the partition number + + method FindNum {item} { + if {![dict exists $elements $item]} { + return -code error \ + -errorcode [list STRUCT DISJOINTSET NOTFOUND $item [self]] \ + "The element \"$item\" is not known to the disjoint\ + set [self]" + } + return [my FindByNum [dict get $elements $item]] + } + + # FindByNum -- + # + # Finds the partition number for an element, given the element's + # index + # + # Parameters: + # idx - Index of the item to look up + # + # Results: + # Returns the partition number + # + # Side effects: + # Performs path splitting + + method FindByNum {idx} { + while {1} { + set parent [lindex $tree $idx 1] + if {$parent == $idx} { + return $idx + } + set prev $idx + set idx $parent + lset tree $prev 1 [lindex $tree $idx 1] + } + } + + # MergeByNum -- + # + # Merges two partitions in a disjoint-sets data structure + # + # Parameters: + # x - Index of an element in the first partition + # y - Index of an element in the second partition + # + # Results: + # None + # + # Side effects: + # Merges the partition of the lower rank into the one of the + # higher rank. + + method MergeByNum {x y} { + set xroot [my FindByNum $x] + set yroot [my FindByNum $y] + + if {$xroot == $yroot} { + # The elements are already in the same partition + return + } + + incr nParts -1 + + # Make xroot the taller tree + if {[lindex $tree $xroot 2] < [lindex $tree $yroot 2]} { + set t $xroot; set xroot $yroot; set yroot $t + } + + # Merge yroot into xroot + set xrank [lindex $tree $xroot 2] + set yrank [lindex $tree $yroot 2] + lset tree $yroot 1 $xroot + if {$xrank == $yrank} { + lset tree $xroot 2 [expr {$xrank + 1}] + } + } +} + +# ::struct::disjointset::disjointset -- +# +# Create a new disjoint set with a given name; if no name is +# given, use disjointsetX, where X is a number. +# +# Arguments: +# name Optional name of the disjoint set; if not specified, generate one. +# +# Results: +# name Name of the disjoint set created + +proc ::struct::disjointset::disjointset {args} { + + switch -exact -- [llength $args] { + 0 { + return [_disjointset new] + } + 1 { + # Name supplied by user + return [uplevel 1 [list [namespace which _disjointset] \ + create [lindex $args 0]]] + } + default { + # Too many args + return -code error \ + -errorcode {TCL WRONGARGS} \ + "wrong # args: should be \"[lindex [info level 0] 0] ?name?\"" + } + } +} + +namespace eval ::struct { + namespace import disjointset::disjointset + namespace export disjointset +} + +package provide struct::disjointset 1.2 +return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graph.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graph.tcl new file mode 100644 index 00000000..d2de11c5 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graph.tcl @@ -0,0 +1,177 @@ +# graph.tcl -- +# +# Implementation of a graph data structure for Tcl. +# +# Copyright (c) 2000-2005,2019 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# @mdgen EXCLUDE: graph_c.tcl + +package require Tcl 8.5 9 + +namespace eval ::struct::graph {} + +# ### ### ### ######### ######### ######### +## Management of graph implementations. + +# ::struct::graph::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::graph::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of graph requires Tcl 8.4. + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::graph_critcl]] + } + tcl { + variable selfdir + source [file join $selfdir graph_tcl.tcl] + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::graph::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::graph::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::graph ::struct::graph_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::graph_$key ::struct::graph + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +# ::struct::graph::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::graph::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::graph::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::graph::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::graph::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::graph { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::graph { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export graph +} + +package provide struct::graph 2.4.4 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graph1.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graph1.tcl new file mode 100644 index 00000000..a81ed014 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graph1.tcl @@ -0,0 +1,2154 @@ +# graph.tcl -- +# +# Implementation of a graph data structure for Tcl. +# +# Copyright (c) 2000 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: graph1.tcl,v 1.5 2008/08/13 20:30:58 mic42 Exp $ + +# Create the namespace before determining cgraph vs. tcl +# Otherwise the loading 'struct.tcl' may get into trouble +# when trying to import commands from them + +namespace eval ::struct {} +namespace eval ::struct::graph {} + +# Try to load the cgraph package + +if {![catch {package require cgraph 0.6}]} { + # the cgraph package takes over, so we can return + return +} + +namespace eval ::struct {} +namespace eval ::struct::graph { + # Data storage in the graph module + # ------------------------------- + # + # There's a lot of bits to keep track of for each graph: + # nodes + # node values + # node relationships (arcs) + # arc values + # + # It would quickly become unwieldy to try to keep these in arrays or lists + # within the graph namespace itself. Instead, each graph structure will + # get its own namespace. Each namespace contains: + # node:$node array mapping keys to values for the node $node + # arc:$arc array mapping keys to values for the arc $arc + # inArcs array mapping nodes to the list of incoming arcs + # outArcs array mapping nodes to the list of outgoing arcs + # arcNodes array mapping arcs to the two nodes (start & end) + + # counter is used to give a unique name for unnamed graph + variable counter 0 + + # commands is the list of subcommands recognized by the graph + variable commands [list \ + "arc" \ + "arcs" \ + "destroy" \ + "get" \ + "getall" \ + "keys" \ + "keyexists" \ + "node" \ + "nodes" \ + "set" \ + "swap" \ + "unset" \ + "walk" \ + ] + + variable arcCommands [list \ + "append" \ + "delete" \ + "exists" \ + "get" \ + "getall" \ + "insert" \ + "keys" \ + "keyexists" \ + "lappend" \ + "set" \ + "source" \ + "target" \ + "unset" \ + ] + + variable nodeCommands [list \ + "append" \ + "degree" \ + "delete" \ + "exists" \ + "get" \ + "getall" \ + "insert" \ + "keys" \ + "keyexists" \ + "lappend" \ + "opposite" \ + "set" \ + "unset" \ + ] + + # Only export one command, the one used to instantiate a new graph + namespace export graph +} + +# ::struct::graph::graph -- +# +# Create a new graph with a given name; if no name is given, use +# graphX, where X is a number. +# +# Arguments: +# name name of the graph; if null, generate one. +# +# Results: +# name name of the graph created + +proc ::struct::graph::graph {{name ""}} { + variable counter + + if { [llength [info level 0]] == 1 } { + incr counter + set name "graph${counter}" + } + + if { ![string equal [info commands ::$name] ""] } { + error "command \"$name\" already exists, unable to create graph" + } + + # Set up the namespace + namespace eval ::struct::graph::graph$name { + + # Set up the map for values associated with the graph itself + variable graphData + array set graphData {data ""} + + # Set up the map from nodes to the arcs coming to them + variable inArcs + array set inArcs {} + + # Set up the map from nodes to the arcs going out from them + variable outArcs + array set outArcs {} + + # Set up the map from arcs to the nodes they touch. + variable arcNodes + array set arcNodes {} + + # Set up a value for use in creating unique node names + variable nextUnusedNode + set nextUnusedNode 1 + + # Set up a value for use in creating unique arc names + variable nextUnusedArc + set nextUnusedArc 1 + } + + # Create the command to manipulate the graph + interp alias {} ::$name {} ::struct::graph::GraphProc $name + + return $name +} + +########################## +# Private functions follow + +# ::struct::graph::GraphProc -- +# +# Command that processes all graph object commands. +# +# Arguments: +# name name of the graph object to manipulate. +# args command name and args for the command +# +# Results: +# Varies based on command to perform + +proc ::struct::graph::GraphProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + if { [llength [info commands ::struct::graph::_$cmd]] == 0 } { + variable commands + set optlist [join $commands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + eval [list ::struct::graph::_$cmd $name] $args +} + +# ::struct::graph::_arc -- +# +# Dispatches the invocation of arc methods to the proper handler +# procedure. +# +# Arguments: +# name name of the graph. +# cmd arc command to invoke +# args arguments to propagate to the handler for the arc command +# +# Results: +# As of the invoked handler. + +proc ::struct::graph::_arc {name cmd args} { + + # Split the args into command and args components + if { [llength [info commands ::struct::graph::__arc_$cmd]] == 0 } { + variable arcCommands + set optlist [join $arcCommands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + + eval [list ::struct::graph::__arc_$cmd $name] $args +} + +# ::struct::graph::__arc_delete -- +# +# Remove an arc from a graph, including all of its values. +# +# Arguments: +# name name of the graph. +# args list of arcs to delete. +# +# Results: +# None. + +proc ::struct::graph::__arc_delete {name args} { + + foreach arc $args { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + } + + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::arcNodes arcNodes + + foreach arc $args { + foreach {source target} $arcNodes($arc) break ; # lassign + + unset arcNodes($arc) + # FRINK: nocheck + unset ::struct::graph::graph${name}::arc$arc + + # Remove arc from the arc lists of source and target nodes. + + set index [lsearch -exact $outArcs($source) $arc] + set outArcs($source) [lreplace $outArcs($source) $index $index] + + set index [lsearch -exact $inArcs($target) $arc] + set inArcs($target) [lreplace $inArcs($target) $index $index] + } + + return +} + +# ::struct::graph::__arc_exists -- +# +# Test for existance of a given arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to look for. +# +# Results: +# 1 if the arc exists, 0 else. + +proc ::struct::graph::__arc_exists {name arc} { + return [info exists ::struct::graph::graph${name}::arcNodes($arc)] +} + +# ::struct::graph::__arc_get -- +# +# Get a keyed value from an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__arc_get {name arc {flag -key} {key data}} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arc${arc} data + + if { ![info exists data($key)] } { + error "invalid key \"$key\" for arc \"$arc\"" + } + + return $data($key) +} + +# ::struct::graph::__arc_getall -- +# +# Get a serialized array of key/value pairs from an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# +# Results: +# value serialized array of key/value pairs. + +proc ::struct::graph::__arc_getall {name arc args} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::arc${arc} data + + return [array get data] +} + +# ::struct::graph::__arc_keys -- +# +# Get a list of keys for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__arc_keys {name arc args} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::arc${arc} data + + return [array names data] +} + +# ::struct::graph::__arc_keyexists -- +# +# Test for existance of a given key for a given arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::__arc_keyexists {name arc {flag -key} {key data}} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + + upvar ::struct::graph::graph${name}::arc${arc} data + + return [info exists data($key)] +} + +# ::struct::graph::__arc_insert -- +# +# Add an arc to a graph. +# +# Arguments: +# name name of the graph. +# source source node of the new arc +# target target node of the new arc +# args arc to insert; must be unique. If none is given, +# the routine will generate a unique node name. +# +# Results: +# arc The name of the new arc. + +proc ::struct::graph::__arc_insert {name source target args} { + + if { [llength $args] == 0 } { + # No arc name was given; generate a unique one + set arc [__generateUniqueArcName $name] + } else { + set arc [lindex $args 0] + } + + if { [__arc_exists $name $arc] } { + error "arc \"$arc\" already exists in graph \"$name\"" + } + + if { ![__node_exists $name $source] } { + error "source node \"$source\" does not exist in graph \"$name\"" + } + + if { ![__node_exists $name $target] } { + error "target node \"$target\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::arcNodes arcNodes + upvar ::struct::graph::graph${name}::arc${arc} data + + # Set up the new arc + set data(data) "" + set arcNodes($arc) [list $source $target] + + # Add this arc to the arc lists of its source resp. target nodes. + lappend outArcs($source) $arc + lappend inArcs($target) $arc + + return $arc +} + +# ::struct::graph::__arc_set -- +# +# Set or get a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# args ?-key key? ?value? +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_set {name arc args} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arc$arc data + + if { [llength $args] > 3 } { + error "wrong # args: should be \"$name arc set $arc ?-key key?\ + ?value?\"" + } + + set key "data" + set haveValue 0 + if { [llength $args] > 1 } { + foreach {flag key} $args break + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be key" + } + if { [llength $args] == 3 } { + set haveValue 1 + set value [lindex $args end] + } + } elseif { [llength $args] == 1 } { + set haveValue 1 + set value [lindex $args end] + } + + if { $haveValue } { + # Setting a value + return [set data($key) $value] + } else { + # Getting a value + if { ![info exists data($key)] } { + error "invalid key \"$key\" for arc \"$arc\"" + } + return $data($key) + } +} + +# ::struct::graph::__arc_append -- +# +# Append a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# args ?-key key? value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_append {name arc args} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arc$arc data + + if { [llength $args] != 1 && [llength $args] != 3 } { + error "wrong # args: should be \"$name arc append $arc ?-key key?\ + value\"" + } + + if { [llength $args] == 3 } { + foreach {flag key} $args break + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + return [append data($key) $value] +} + +# ::struct::graph::__arc_lappend -- +# +# lappend a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# args ?-key key? value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_lappend {name arc args} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arc$arc data + + if { [llength $args] != 1 && [llength $args] != 3 } { + error "wrong # args: should be \"$name arc lappend $arc ?-key key?\ + value\"" + } + + if { [llength $args] == 3 } { + foreach {flag key} $args break + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + return [lappend data($key) $value] +} + +# ::struct::graph::__arc_source -- +# +# Return the node at the beginning of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to look up. +# +# Results: +# node name of the node. + +proc ::struct::graph::__arc_source {name arc} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arcNodes arcNodes + return [lindex $arcNodes($arc) 0] +} + +# ::struct::graph::__arc_target -- +# +# Return the node at the end of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to look up. +# +# Results: +# node name of the node. + +proc ::struct::graph::__arc_target {name arc} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arcNodes arcNodes + return [lindex $arcNodes($arc) 1] +} + +# ::struct::graph::__arc_unset -- +# +# Remove a keyed value from a arc. +# +# Arguments: +# name name of the graph. +# arc arc to modify. +# args additional args: ?-key key? +# +# Results: +# None. + +proc ::struct::graph::__arc_unset {name arc {flag -key} {key data}} { + if { ![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be \"$name arc unset\ + $arc ?-key key?\"" + } + + upvar ::struct::graph::graph${name}::arc${arc} data + if { [info exists data($key)] } { + unset data($key) + } + return +} + +# ::struct::graph::_arcs -- +# +# Return a list of all arcs in a graph satisfying some +# node based restriction. +# +# Arguments: +# name name of the graph. +# +# Results: +# arcs list of arcs + +proc ::struct::graph::_arcs {name args} { + + # Discriminate between conditions and nodes + + set haveCond 0 + set haveKey 0 + set haveValue 0 + set cond "none" + set condNodes [list] + + for {set i 0} {$i < [llength $args]} {incr i} { + set arg [lindex $args $i] + switch -glob -- $arg { + -in - + -out - + -adj - + -inner - + -embedding { + if {$haveCond} { + return -code error "invalid restriction:\ + illegal multiple use of\ + \"-in\"|\"-out\"|\"-adj\"|\"-inner\"|\"-embedding\"" + } + + set haveCond 1 + set cond [string range $arg 1 end] + } + -key { + if {$haveKey} { + return -code error {invalid restriction: illegal multiple use of "-key"} + } + + incr i + set key [lindex $args $i] + set haveKey 1 + } + -value { + if {$haveValue} { + return -code error {invalid restriction: illegal multiple use of "-value"} + } + + incr i + set value [lindex $args $i] + set haveValue 1 + } + -* { + error "invalid restriction \"$arg\": should be -in, -out,\ + -adj, -inner, -embedding, -key or -value" + } + default { + lappend condNodes $arg + } + } + } + + # Validate that there are nodes to use in the restriction. + # otherwise what's the point? + if {$haveCond} { + if {[llength $condNodes] == 0} { + set usage "$name arcs ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?" + error "no nodes specified: should be \"$usage\"" + } + + # Make sure that the specified nodes exist! + foreach node $condNodes { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + } + } + + # Now we are able to go to work + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::arcNodes arcNodes + + set arcs [list] + + switch -exact -- $cond { + in { + # Result is all arcs going to at least one node + # in the list of arguments. + + foreach node $condNodes { + foreach e $inArcs($node) { + # As an arc has only one destination, i.e. is the + # in-arc of exactly one node it is impossible to + # count an arc twice. IOW the [info exists] below + # is never true. Found through coverage analysis + # and then trying to think up a testcase invoking + # the continue. + # if {[info exists coll($e)]} {continue} + lappend arcs $e + #set coll($e) . + } + } + } + out { + # Result is all arcs coming from at least one node + # in the list of arguments. + + foreach node $condNodes { + foreach e $outArcs($node) { + # See above 'in', same reasoning, one source per arc. + # if {[info exists coll($e)]} {continue} + lappend arcs $e + #set coll($e) . + } + } + } + adj { + # Result is all arcs coming from or going to at + # least one node in the list of arguments. + + array set coll {} + # Here we do need 'coll' as each might be an in- and + # out-arc for one or two nodes in the list of arguments. + + foreach node $condNodes { + foreach e $inArcs($node) { + if {[info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + foreach e $outArcs($node) { + if {[info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + } + } + inner { + # Result is all arcs running between nodes in the list. + + array set coll {} + # Here we do need 'coll' as each might be an in- and + # out-arc for one or two nodes in the list of arguments. + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {![info exists group($n)]} {continue} + if { [info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {![info exists group($n)]} {continue} + if { [info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + } + } + embedding { + # Result is all arcs from -adj minus the arcs from -inner. + # IOW all arcs going from a node in the list to a node + # which is *not* in the list + + # This also means that no arc can be counted twice as it + # is either going to a node, or coming from a node in the + # list, but it can't do both, because then it is part of + # -inner, which was excluded! + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists group($n)]} {continue} + # if {[info exists coll($e)]} {continue} + lappend arcs $e + # set coll($e) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists group($n)]} {continue} + # if {[info exists coll($e)]} {continue} + lappend arcs $e + # set coll($e) . + } + } + } + none { + set arcs [array names arcNodes] + } + default {error "Can't happen, panic"} + } + + # + # We have a list of arcs that match the relation to the nodes. + # Now filter according to -key and -value. + # + + set filteredArcs [list] + + if {$haveKey} { + foreach arc $arcs { + catch { + set aval [__arc_get $name $arc -key $key] + if {$haveValue} { + if {$aval == $value} { + lappend filteredArcs $arc + } + } else { + lappend filteredArcs $arc + } + } + } + } else { + set filteredArcs $arcs + } + + return $filteredArcs +} + +# ::struct::graph::_destroy -- +# +# Destroy a graph, including its associated command and data storage. +# +# Arguments: +# name name of the graph. +# +# Results: +# None. + +proc ::struct::graph::_destroy {name} { + namespace delete ::struct::graph::graph$name + interp alias {} ::$name {} +} + +# ::struct::graph::__generateUniqueArcName -- +# +# Generate a unique arc name for the given graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# arc name of a arc guaranteed to not exist in the graph. + +proc ::struct::graph::__generateUniqueArcName {name} { + upvar ::struct::graph::graph${name}::nextUnusedArc nextUnusedArc + while {[__arc_exists $name "arc${nextUnusedArc}"]} { + incr nextUnusedArc + } + return "arc${nextUnusedArc}" +} + +# ::struct::graph::__generateUniqueNodeName -- +# +# Generate a unique node name for the given graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# node name of a node guaranteed to not exist in the graph. + +proc ::struct::graph::__generateUniqueNodeName {name} { + upvar ::struct::graph::graph${name}::nextUnusedNode nextUnusedNode + while {[__node_exists $name "node${nextUnusedNode}"]} { + incr nextUnusedNode + } + return "node${nextUnusedNode}" +} + +# ::struct::graph::_get -- +# +# Get a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_get {name {flag -key} {key data}} { + upvar ::struct::graph::graph${name}::graphData data + + if { ![info exists data($key)] } { + error "invalid key \"$key\" for graph \"$name\"" + } + + return $data($key) +} + +# ::struct::graph::_getall -- +# +# Get a serialized list of key/value pairs from a graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_getall {name args} { + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::graphData data + return [array get data] +} + +# ::struct::graph::_keys -- +# +# Get a list of keys from a graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# value list of known keys + +proc ::struct::graph::_keys {name args} { + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::graphData data + return [array names data] +} + +# ::struct::graph::_keyexists -- +# +# Test for existance of a given key in a graph. +# +# Arguments: +# name name of the graph. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::_keyexists {name {flag -key} {key data}} { + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + + upvar ::struct::graph::graph${name}::graphData data + return [info exists data($key)] +} + +# ::struct::graph::_node -- +# +# Dispatches the invocation of node methods to the proper handler +# procedure. +# +# Arguments: +# name name of the graph. +# cmd node command to invoke +# args arguments to propagate to the handler for the node command +# +# Results: +# As of the the invoked handler. + +proc ::struct::graph::_node {name cmd args} { + + # Split the args into command and args components + if { [llength [info commands ::struct::graph::__node_$cmd]] == 0 } { + variable nodeCommands + set optlist [join $nodeCommands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + + eval [list ::struct::graph::__node_$cmd $name] $args +} + +# ::struct::graph::__node_degree -- +# +# Return the number of arcs adjacent to the specified node. +# If one of the restrictions -in or -out is given only +# incoming resp. outgoing arcs are counted. +# +# Arguments: +# name name of the graph. +# args option, followed by the node. +# +# Results: +# None. + +proc ::struct::graph::__node_degree {name args} { + + if {([llength $args] < 1) || ([llength $args] > 2)} { + error "wrong # args: should be \"$name node degree ?-in|-out? node\"" + } + + switch -exact -- [llength $args] { + 1 { + set opt {} + set node [lindex $args 0] + } + 2 { + set opt [lindex $args 0] + set node [lindex $args 1] + } + default {error "Can't happen, panic"} + } + + # Validate the option. + + switch -exact -- $opt { + {} - + -in - + -out {} + default { + error "invalid option \"$opt\": should be -in or -out" + } + } + + # Validate the node + + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + + switch -exact -- $opt { + -in { + set result [llength $inArcs($node)] + } + -out { + set result [llength $outArcs($node)] + } + {} { + set result [expr {[llength $inArcs($node)] \ + + [llength $outArcs($node)]}] + + # loops count twice, don't do arithmetics, i.e. no union! + if {0} { + array set coll {} + set result [llength $inArcs($node)] + + foreach e $inArcs($node) { + set coll($e) . + } + foreach e $outArcs($node) { + if {[info exists coll($e)]} {continue} + incr result + set coll($e) . + } + } + } + default {error "Can't happen, panic"} + } + + return $result +} + +# ::struct::graph::__node_delete -- +# +# Remove a node from a graph, including all of its values. +# Additionally removes the arcs connected to this node. +# +# Arguments: +# name name of the graph. +# args list of the nodes to delete. +# +# Results: +# None. + +proc ::struct::graph::__node_delete {name args} { + + foreach node $args { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + } + + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + + foreach node $args { + # Remove all the arcs connected to this node + foreach e $inArcs($node) { + __arc_delete $name $e + } + foreach e $outArcs($node) { + # Check existence to avoid problems with + # loops (they are in and out arcs! at + # the same time and thus already deleted) + if { [__arc_exists $name $e] } { + __arc_delete $name $e + } + } + + unset inArcs($node) + unset outArcs($node) + # FRINK: nocheck + unset ::struct::graph::graph${name}::node$node + } + + return +} + +# ::struct::graph::__node_exists -- +# +# Test for existance of a given node in a graph. +# +# Arguments: +# name name of the graph. +# node node to look for. +# +# Results: +# 1 if the node exists, 0 else. + +proc ::struct::graph::__node_exists {name node} { + return [info exists ::struct::graph::graph${name}::inArcs($node)] +} + +# ::struct::graph::__node_get -- +# +# Get a keyed value from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_get {name node {flag -key} {key data}} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::node${node} data + + if { ![info exists data($key)] } { + error "invalid key \"$key\" for node \"$node\"" + } + + return $data($key) +} + +# ::struct::graph::__node_getall -- +# +# Get a serialized list of key/value pairs from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_getall {name node args} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::node${node} data + + return [array get data] +} + +# ::struct::graph::__node_keys -- +# +# Get a list of keys from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_keys {name node args} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + if { [llength $args] } { + error "wrong # args: should be none" + } + + upvar ::struct::graph::graph${name}::node${node} data + + return [array names data] +} + +# ::struct::graph::__node_keyexists -- +# +# Test for existance of a given key for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# flag -key; anything else is an error +# key key to lookup; defaults to data +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::__node_keyexists {name node {flag -key} {key data}} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + + upvar ::struct::graph::graph${name}::node${node} data + + return [info exists data($key)] +} + +# ::struct::graph::__node_insert -- +# +# Add a node to a graph. +# +# Arguments: +# name name of the graph. +# args node to insert; must be unique. If none is given, +# the routine will generate a unique node name. +# +# Results: +# node The namee of the new node. + +proc ::struct::graph::__node_insert {name args} { + + if { [llength $args] == 0 } { + # No node name was given; generate a unique one + set node [__generateUniqueNodeName $name] + } else { + set node [lindex $args 0] + } + + if { [__node_exists $name $node] } { + error "node \"$node\" already exists in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::node${node} data + + # Set up the new node + set inArcs($node) [list] + set outArcs($node) [list] + set data(data) "" + + return $node +} + +# ::struct::graph::__node_opposite -- +# +# Retrieve node opposite to the specified one, along the arc. +# +# Arguments: +# name name of the graph. +# node node to look up. +# arc arc to look up. +# +# Results: +# nodex Node opposite to + +proc ::struct::graph::__node_opposite {name node arc} { + if {![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + if {![__arc_exists $name $arc] } { + error "arc \"$arc\" does not exist in graph \"$name\"" + } + + upvar ::struct::graph::graph${name}::arcNodes arcNodes + + # Node must be connected to at least one end of the arc. + + if {[string equal $node [lindex $arcNodes($arc) 0]]} { + set result [lindex $arcNodes($arc) 1] + } elseif {[string equal $node [lindex $arcNodes($arc) 1]]} { + set result [lindex $arcNodes($arc) 0] + } else { + error "node \"$node\" and arc \"$arc\" are not connected\ + in graph \"$name\"" + } + + return $result +} + +# ::struct::graph::__node_set -- +# +# Set or get a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# args ?-key key? ?value? +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_set {name node args} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + upvar ::struct::graph::graph${name}::node$node data + + if { [llength $args] > 3 } { + error "wrong # args: should be \"$name node set $node ?-key key?\ + ?value?\"" + } + + set key "data" + set haveValue 0 + if { [llength $args] > 1 } { + foreach {flag key} $args break + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be key" + } + if { [llength $args] == 3 } { + set haveValue 1 + set value [lindex $args end] + } + } elseif { [llength $args] == 1 } { + set haveValue 1 + set value [lindex $args end] + } + + if { $haveValue } { + # Setting a value + return [set data($key) $value] + } else { + # Getting a value + if { ![info exists data($key)] } { + error "invalid key \"$key\" for node \"$node\"" + } + return $data($key) + } +} + +# ::struct::graph::__node_append -- +# +# Append a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# args ?-key key? value +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_append {name node args} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + upvar ::struct::graph::graph${name}::node$node data + + if { [llength $args] != 1 && [llength $args] != 3 } { + error "wrong # args: should be \"$name node append $node ?-key key?\ + value\"" + } + + if { [llength $args] == 3 } { + foreach {flag key} $args break + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + return [append data($key) $value] +} + +# ::struct::graph::__node_lappend -- +# +# lappend a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# args ?-key key? value +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_lappend {name node args} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + upvar ::struct::graph::graph${name}::node$node data + + if { [llength $args] != 1 && [llength $args] != 3 } { + error "wrong # args: should be \"$name node lappend $node ?-key key?\ + value\"" + } + + if { [llength $args] == 3 } { + foreach {flag key} $args break + if { ![string equal $flag "-key"] } { + error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + return [lappend data($key) $value] +} + +# ::struct::graph::__node_unset -- +# +# Remove a keyed value from a node. +# +# Arguments: +# name name of the graph. +# node node to modify. +# args additional args: ?-key key? +# +# Results: +# None. + +proc ::struct::graph::__node_unset {name node {flag -key} {key data}} { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be \"$name node unset\ + $node ?-key key?\"" + } + + upvar ::struct::graph::graph${name}::node${node} data + if { [info exists data($key)] } { + unset data($key) + } + return +} + +# ::struct::graph::_nodes -- +# +# Return a list of all nodes in a graph satisfying some restriction. +# +# Arguments: +# name name of the graph. +# args list of options and nodes specifying the restriction. +# +# Results: +# nodes list of nodes + +proc ::struct::graph::_nodes {name args} { + + # Discriminate between conditions and nodes + + set haveCond 0 + set haveKey 0 + set haveValue 0 + set cond "none" + set condNodes [list] + + for {set i 0} {$i < [llength $args]} {incr i} { + set arg [lindex $args $i] + switch -glob -- $arg { + -in - + -out - + -adj - + -inner - + -embedding { + if {$haveCond} { + return -code error "invalid restriction:\ + illegal multiple use of\ + \"-in\"|\"-out\"|\"-adj\"|\"-inner\"|\"-embedding\"" + } + + set haveCond 1 + set cond [string range $arg 1 end] + } + -key { + if {$haveKey} { + return -code error {invalid restriction: illegal multiple use of "-key"} + } + + incr i + set key [lindex $args $i] + set haveKey 1 + } + -value { + if {$haveValue} { + return -code error {invalid restriction: illegal multiple use of "-value"} + } + + incr i + set value [lindex $args $i] + set haveValue 1 + } + -* { + error "invalid restriction \"$arg\": should be -in, -out,\ + -adj, -inner, -embedding, -key or -value" + } + default { + lappend condNodes $arg + } + } + } + + # Validate that there are nodes to use in the restriction. + # otherwise what's the point? + if {$haveCond} { + if {[llength $condNodes] == 0} { + set usage "$name nodes ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?" + error "no nodes specified: should be \"$usage\"" + } + + # Make sure that the specified nodes exist! + foreach node $condNodes { + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + } + } + + # Now we are able to go to work + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::arcNodes arcNodes + + set nodes [list] + array set coll {} + + switch -exact -- $cond { + in { + # Result is all nodes with at least one arc going to + # at least one node in the list of arguments. + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } + out { + # Result is all nodes with at least one arc coming from + # at least one node in the list of arguments. + + foreach node $condNodes { + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } + adj { + # Result is all nodes with at least one arc coming from + # or going to at least one node in the list of arguments. + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } + inner { + # Result is all nodes from the list! with at least one arc + # coming from or going to at least one node in the list of + # arguments. + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {![info exists group($n)]} {continue} + if { [info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {![info exists group($n)]} {continue} + if { [info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } + embedding { + # Result is all nodes with at least one arc coming from + # or going to at least one node in the list of arguments, + # but not in the list itself! + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists group($n)]} {continue} + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists group($n)]} {continue} + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } + none { + set nodes [array names inArcs] + } + default {error "Can't happen, panic"} + } + + # + # We have a list of nodes that match the relation to the nodes. + # Now filter according to -key and -value. + # + + set filteredNodes [list] + + if {$haveKey} { + foreach node $nodes { + catch { + set nval [__node_get $name $node -key $key] + if {$haveValue} { + if {$nval == $value} { + lappend filteredNodes $node + } + } else { + lappend filteredNodes $node + } + } + } + } else { + set filteredNodes $nodes + } + + return $filteredNodes +} + +# ::struct::graph::_set -- +# +# Set or get a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# flag -key; anything else is an error +# args ?-key key? ?value? +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_set {name args} { + upvar ::struct::graph::graph${name}::graphData data + + if { [llength $args] > 3 } { + error "wrong # args: should be \"$name set ?-key key?\ + ?value?\"" + } + + set key "data" + set haveValue 0 + if { [llength $args] > 1 } { + foreach {flag key} $args break + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be key" + } + if { [llength $args] == 3 } { + set haveValue 1 + set value [lindex $args end] + } + } elseif { [llength $args] == 1 } { + set haveValue 1 + set value [lindex $args end] + } + + if { $haveValue } { + # Setting a value + return [set data($key) $value] + } else { + # Getting a value + if { ![info exists data($key)] } { + error "invalid key \"$key\" for graph \"$name\"" + } + return $data($key) + } +} + +# ::struct::graph::_swap -- +# +# Swap two nodes in a graph. +# +# Arguments: +# name name of the graph. +# node1 first node to swap. +# node2 second node to swap. +# +# Results: +# None. + +proc ::struct::graph::_swap {name node1 node2} { + # Can only swap two real nodes + if { ![__node_exists $name $node1] } { + error "node \"$node1\" does not exist in graph \"$name\"" + } + if { ![__node_exists $name $node2] } { + error "node \"$node2\" does not exist in graph \"$name\"" + } + + # Can't swap a node with itself + if { [string equal $node1 $node2] } { + error "cannot swap node \"$node1\" with itself" + } + + # Swapping nodes means swapping their labels, values and arcs + upvar ::struct::graph::graph${name}::outArcs outArcs + upvar ::struct::graph::graph${name}::inArcs inArcs + upvar ::struct::graph::graph${name}::arcNodes arcNodes + upvar ::struct::graph::graph${name}::node${node1} node1Vals + upvar ::struct::graph::graph${name}::node${node2} node2Vals + + # Redirect arcs to the new nodes. + + foreach e $inArcs($node1) { + set arcNodes($e) [lreplace $arcNodes($e) end end $node2] + } + foreach e $inArcs($node2) { + set arcNodes($e) [lreplace $arcNodes($e) end end $node1] + } + foreach e $outArcs($node1) { + set arcNodes($e) [lreplace $arcNodes($e) 0 0 $node2] + } + foreach e $outArcs($node2) { + set arcNodes($e) [lreplace $arcNodes($e) 0 0 $node1] + } + + # Swap arc lists + + set tmp $inArcs($node1) + set inArcs($node1) $inArcs($node2) + set inArcs($node2) $tmp + + set tmp $outArcs($node1) + set outArcs($node1) $outArcs($node2) + set outArcs($node2) $tmp + + # Swap the values + set value1 [array get node1Vals] + unset node1Vals + array set node1Vals [array get node2Vals] + unset node2Vals + array set node2Vals $value1 + + return +} + +# ::struct::graph::_unset -- +# +# Remove a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# flag -key; anything else is an error +# args additional args: ?-key key? +# +# Results: +# None. + +proc ::struct::graph::_unset {name {flag -key} {key data}} { + upvar ::struct::graph::graph${name}::graphData data + + if { ![string match "${flag}*" "-key"] } { + error "invalid option \"$flag\": should be \"$name unset\ + ?-key key?\"" + } + + if { [info exists data($key)] } { + unset data($key) + } + + return +} + +# ::struct::graph::_walk -- +# +# Walk a graph using a pre-order depth or breadth first +# search. Pre-order DFS is the default. At each node that is visited, +# a command will be called with the name of the graph and the node. +# +# Arguments: +# name name of the graph. +# node node at which to start. +# args additional args: ?-order pre|post|both? ?-type {bfs|dfs}? +# -command cmd +# +# Results: +# None. + +proc ::struct::graph::_walk {name node args} { + set usage "$name walk $node ?-dir forward|backward?\ + ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd" + + if {[llength $args] > 8 || [llength $args] < 2} { + error "wrong # args: should be \"$usage\"" + } + + if { ![__node_exists $name $node] } { + error "node \"$node\" does not exist in graph \"$name\"" + } + + # Set defaults + set type dfs + set order pre + set cmd "" + set dir forward + + # Process specified options + for {set i 0} {$i < [llength $args]} {incr i} { + set flag [lindex $args $i] + incr i + if { $i >= [llength $args] } { + error "value for \"$flag\" missing: should be \"$usage\"" + } + switch -glob -- $flag { + "-type" { + set type [string tolower [lindex $args $i]] + } + "-order" { + set order [string tolower [lindex $args $i]] + } + "-command" { + set cmd [lindex $args $i] + } + "-dir" { + set dir [string tolower [lindex $args $i]] + } + default { + error "unknown option \"$flag\": should be \"$usage\"" + } + } + } + + # Make sure we have a command to run, otherwise what's the point? + if { [string equal $cmd ""] } { + error "no command specified: should be \"$usage\"" + } + + # Validate that the given type is good + switch -glob -- $type { + "dfs" { + set type "dfs" + } + "bfs" { + set type "bfs" + } + default { + error "invalid search type \"$type\": should be dfs, or bfs" + } + } + + # Validate that the given order is good + switch -glob -- $order { + "both" { + set order both + } + "pre" { + set order pre + } + "post" { + set order post + } + default { + error "invalid search order \"$order\": should be both,\ + pre or post" + } + } + + # Validate that the given direction is good + switch -glob -- $dir { + "forward" { + set dir -out + } + "backward" { + set dir -in + } + default { + error "invalid search direction \"$dir\": should be\ + forward or backward" + } + } + + # Do the walk + + set st [list ] + lappend st $node + array set visited {} + + if { [string equal $type "dfs"] } { + if { [string equal $order "pre"] } { + # Pre-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + set st [lreplace $st end end] + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 2 $cmdcpy + + set visited($node) . + + # Add this node's neighbours (according to direction) + # Have to add them in reverse order + # so that they will be popped left-to-right + + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } elseif { [string equal $order "post"] } { + # Post-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are here, pop it, + # then evaluate the command. + + set st [lreplace $st end end] + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy leave $name $node + uplevel 2 $cmdcpy + } else { + # First visit. Remember it. + set visited($node) . + + # Add this node's neighbours. + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } + } else { + # Both-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are here, pop it, + # then evaluate the command. + + set st [lreplace $st end end] + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy leave $name $node + uplevel 2 $cmdcpy + } else { + # First visit. Remember it. + set visited($node) . + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 2 $cmdcpy + + # Add this node's neighbours. + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } + } + + } else { + if { [string equal $order "pre"] } { + # Pre-order Breadth first search + while { [llength $st] > 0 } { + set node [lindex $st 0] + set st [lreplace $st 0 0] + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 2 $cmdcpy + + set visited($node) . + + # Add this node's neighbours. + foreach child [_nodes $name $dir $node] { + if {[info exists visited($child)]} { + # Skip nodes already visited + continue + } + lappend st $child + } + } + } else { + # Post-order Breadth first search + # Both-order Breadth first search + # Haven't found anything in Knuth + # and unable to define something + # consistent for myself. Leave it + # out. + + error "unable to do a ${order}-order breadth first walk" + } + } + return +} + +# ::struct::graph::Union -- +# +# Return a list which is the union of the elements +# in the specified lists. +# +# Arguments: +# args list of lists representing sets. +# +# Results: +# set list representing the union of the argument lists. + +proc ::struct::graph::Union {args} { + switch -- [llength $args] { + 0 { + return {} + } + 1 { + return [lindex $args 0] + } + default { + foreach set $args { + foreach e $set { + set tmp($e) . + } + } + return [array names tmp] + } + } +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'graph::graph' into the general structure namespace. + namespace import -force graph::graph + namespace export graph +} +package provide struct::graph 1.2.2 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graph_c.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graph_c.tcl new file mode 100644 index 00000000..98d608e8 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graph_c.tcl @@ -0,0 +1,158 @@ +# graphc.tcl -- +# +# Implementation of a graph data structure for Tcl. +# This code based on critcl, API compatible to the PTI [x]. +# [x] Pure Tcl Implementation. +# +# Copyright (c) 2006,2019 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require critcl +# @sak notprovided struct_graphc +package provide struct_graphc 2.4.4 +package require Tcl 8.5 9 + +namespace eval ::struct { + # Supporting code for the main command. + + catch { + #critcl::cheaders -g + #critcl::debug memory symbols + } + + critcl::cheaders graph/*.h + critcl::csources graph/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include + #include + #include + + #define USAGE "?name ?=|:=|as|deserialize source??" + + static void gg_delete (ClientData clientData) + { + /* Release the whole graph. */ + g_delete ((G*) clientData); + } + } + + # Main command, graph creation. + + critcl::ccommand graph_critcl {dummy interp objc objv} { + /* Syntax */ + /* - epsilon |1 */ + /* - name |2 */ + /* - name =|:=|as|deserialize source |4 */ + + CONST char* name; + G* g; + Tcl_Obj* fqn; + Tcl_CmdInfo ci; + + if ((objc != 4) && (objc != 2) && (objc != 1)) { + Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ + return TCL_ERROR; + } + + if (objc < 2) { + name = gg_new (interp); + } else { + name = Tcl_GetString (objv [1]); + } + + if (!Tcl_StringMatch (name, "::*")) { + /* Relative name. Prefix with current namespace */ + + Tcl_Eval (interp, "namespace current"); + fqn = Tcl_GetObjResult (interp); + fqn = Tcl_DuplicateObj (fqn); + Tcl_IncrRefCount (fqn); + + if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { + Tcl_AppendToObj (fqn, "::", -1); /* OK tcl9 */ + } + Tcl_AppendToObj (fqn, name, -1); /* OK tcl9 */ + } else { + fqn = Tcl_NewStringObj (name, -1); /* OK tcl9 */ + Tcl_IncrRefCount (fqn); + } + + Tcl_ResetResult (interp); + + if (Tcl_GetCommandInfo (interp, Tcl_GetString (fqn), &ci)) { + Tcl_Obj* err; + + err = Tcl_NewObj (); + Tcl_AppendToObj (err, "command \"", -1); /* OK tcl9 */ + Tcl_AppendObjToObj (err, fqn); + Tcl_AppendToObj (err, "\" already exists, unable to create graph", -1); /* OK tcl9 */ + + Tcl_DecrRefCount (fqn); + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + if (objc == 4) { + /* Construction with immediate initialization */ + /* through deserialization */ + + Tcl_Obj* type = objv[2]; + Tcl_Obj* src = objv[3]; + int srctype; + + static CONST char* types [] = { + ":=", "=", "as", "deserialize", NULL + }; + enum types { + G_ASSIGN, G_IS, G_AS, G_DESER + }; + + if (Tcl_GetIndexFromObj (interp, type, types, "type", 0, &srctype) != TCL_OK) { + Tcl_DecrRefCount (fqn); + Tcl_ResetResult (interp); + Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ + return TCL_ERROR; + } + + g = g_new (); + + switch (srctype) { + case G_ASSIGN: + case G_AS: + case G_IS: + if (g_ms_assign (interp, g, src) != TCL_OK) { + g_delete (g); + Tcl_DecrRefCount (fqn); + return TCL_ERROR; + } + break; + + case G_DESER: + if (g_deserialize (g, interp, src) != TCL_OK) { + g_delete (g); + Tcl_DecrRefCount (fqn); + return TCL_ERROR; + } + break; + } + } else { + g = g_new (); + } + + g->cmd = Tcl_CreateObjCommand2 (interp, Tcl_GetString (fqn), + g_objcmd, (ClientData) g, + gg_delete); + + Tcl_SetObjResult (interp, fqn); + Tcl_DecrRefCount (fqn); + return TCL_OK; + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graph_tcl.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graph_tcl.tcl new file mode 100644 index 00000000..c780a7d0 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graph_tcl.tcl @@ -0,0 +1,3279 @@ +# graph_tcl.tcl -- +# +# Implementation of a graph data structure for Tcl. +# +# Copyright (c) 2000-2009,2019 by Andreas Kupries +# Copyright (c) 2008 by Alejandro Paz +# +# 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 9 +package require struct::list +package require struct::set + +namespace eval ::struct::graph { + # Data storage in the graph module + # ------------------------------- + # + # There's a lot of bits to keep track of for each graph: + # nodes + # node values + # node relationships (arcs) + # arc values + # + # It would quickly become unwieldy to try to keep these in arrays or lists + # within the graph namespace itself. Instead, each graph structure will + # get its own namespace. Each namespace contains: + # node:$node array mapping keys to values for the node $node + # arc:$arc array mapping keys to values for the arc $arc + # inArcs array mapping nodes to the list of incoming arcs + # outArcs array mapping nodes to the list of outgoing arcs + # arcNodes array mapping arcs to the two nodes (start & end) + + # counter is used to give a unique name for unnamed graph + variable counter 0 + + # Only export one command, the one used to instantiate a new graph + namespace export graph_tcl +} + +# ::struct::graph::graph_tcl -- +# +# Create a new graph with a given name; if no name is given, use +# graphX, where X is a number. +# +# Arguments: +# name name of the graph; if null, generate one. +# +# Results: +# name name of the graph created + +proc ::struct::graph::graph_tcl {args} { + variable counter + + set src {} + set srctype {} + + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "graph${counter}" + } + 2 { + # Standard call. New empty graph. + set name [lindex $args 0] + } + 4 { + # Copy construction. + foreach {name as src} $args break + switch -exact -- $as { + = - := - as { + set srctype graph + } + deserialize { + set srctype serial + } + default { + return -code error \ + "wrong # args: should be \"struct::graph ?name ?=|:=|as|deserialize source??\"" + } + } + } + default { + # Error. + return -code error \ + "wrong # args: should be \"struct::graph ?name ?=|:=|as|deserialize source??\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + if {[llength [info commands $name]]} { + return -code error "command \"$name\" already exists, unable to create graph" + } + + # Set up the namespace + namespace eval $name { + + # Set up the map for values associated with the graph itself + variable graphAttr + array set graphAttr {} + + # Set up the node attribute mapping + variable nodeAttr + array set nodeAttr {} + + # Set up the arc attribute mapping + variable arcAttr + array set arcAttr {} + + # Set up the map from nodes to the arcs coming to them + variable inArcs + array set inArcs {} + + # Set up the map from nodes to the arcs going out from them + variable outArcs + array set outArcs {} + + # Set up the map from arcs to the nodes they touch. + variable arcNodes + array set arcNodes {} + + # Set up a value for use in creating unique node names + variable nextUnusedNode + set nextUnusedNode 1 + + # Set up a value for use in creating unique arc names + variable nextUnusedArc + set nextUnusedArc 1 + + # Set up a counter for use in creating attribute arrays. + variable nextAttr + set nextAttr 0 + + # Set up a map from arcs to their weights. Note: Only arcs + # which actually have a weight are recorded in the map, to + # keep memory usage down. + variable arcWeight + array set arcWeight {} + } + + # Create the command to manipulate the graph + interp alias {} $name {} ::struct::graph::GraphProc $name + + # Automatic execution of assignment if a source + # is present. + if {$src != {}} { + switch -exact -- $srctype { + graph {_= $name $src} + serial {_deserialize $name $src} + default { + return -code error \ + "Internal error, illegal srctype \"$srctype\"" + } + } + } + + return $name +} + +########################## +# Private functions follow + +# ::struct::graph::GraphProc -- +# +# Command that processes all graph object commands. +# +# Arguments: +# name name of the graph object to manipulate. +# args command name and args for the command +# +# Results: +# Varies based on command to perform + +proc ::struct::graph::GraphProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub _$cmd + if { [llength [info commands ::struct::graph::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::graph::_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + if {[string match __* $p]} {continue} + lappend xlist [string range $p 1 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::graph::$sub $name] +} + +# ::struct::graph::_= -- +# +# Assignment operator. Copies the source graph into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the graph object we are copying into. +# source Name of the graph object providing us with the +# data to copy. +# +# Results: +# Nothing. + +proc ::struct::graph::_= {name source} { + _deserialize $name [$source serialize] + return +} + +# ::struct::graph::_--> -- +# +# Reverse assignment operator. Copies this graph into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the graph object to copy +# dest Name of the graph object we are copying to. +# +# Results: +# Nothing. + +proc ::struct::graph::_--> {name dest} { + $dest deserialize [_serialize $name] + return +} + +# ::struct::graph::_append -- +# +# Append a value for an attribute in a graph. +# +# Arguments: +# name name of the graph. +# args key value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::_append {name key value} { + variable ${name}::graphAttr + return [append graphAttr($key) $value] +} + +# ::struct::graph::_lappend -- +# +# lappend a value for an attribute in a graph. +# +# Arguments: +# name name of the graph. +# args key value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::_lappend {name key value} { + variable ${name}::graphAttr + return [lappend graphAttr($key) $value] +} + +# ::struct::graph::_arc -- +# +# Dispatches the invocation of arc methods to the proper handler +# procedure. +# +# Arguments: +# name name of the graph. +# cmd arc command to invoke +# args arguments to propagate to the handler for the arc command +# +# Results: +# As of the invoked handler. + +proc ::struct::graph::_arc {name cmd args} { + # Split the args into command and args components + + set sub __arc_$cmd + if { [llength [info commands ::struct::graph::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::graph::__arc_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::graph::$sub $name] +} + +# ::struct::graph::__arc_delete -- +# +# Remove an arc from a graph, including all of its values. +# +# Arguments: +# name name of the graph. +# args list of arcs to delete. +# +# Results: +# None. + +proc ::struct::graph::__arc_delete {name args} { + if {![llength $args]} { + return {wrong # args: should be "::struct::graph::__arc_delete name arc arc..."} + } + + # seen is used to catch duplicate arcs in the args + array set seen {} + foreach arc $args { + if {[info exists seen($arc)]} { + return -code error "arc \"$arc\" does not exist in graph \"$name\"" + } + CheckMissingArc $name $arc + set seen($arc) . + } + + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::arcNodes + variable ${name}::arcAttr + variable ${name}::arcWeight + + foreach arc $args { + foreach {source target} $arcNodes($arc) break ; # lassign + + unset arcNodes($arc) + + if {[info exists arcAttr($arc)]} { + unset ${name}::$arcAttr($arc) ;# Note the double indirection here + unset arcAttr($arc) + } + if {[info exists arcWeight($arc)]} { + unset arcWeight($arc) + } + + # Remove arc from the arc lists of source and target nodes. + + set index [lsearch -exact $outArcs($source) $arc] + ldelete outArcs($source) $index + + set index [lsearch -exact $inArcs($target) $arc] + ldelete inArcs($target) $index + } + + return +} + +# ::struct::graph::__arc_exists -- +# +# Test for existence of a given arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to look for. +# +# Results: +# 1 if the arc exists, 0 else. + +proc ::struct::graph::__arc_exists {name arc} { + return [info exists ${name}::arcNodes($arc)] +} + +# ::struct::graph::__arc_flip -- +# +# Exchanges origin and destination node of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to change. +# +# Results: +# None + +proc ::struct::graph::__arc_flip {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcNodes + variable ${name}::outArcs + variable ${name}::inArcs + + set oldsource [lindex $arcNodes($arc) 0] + set oldtarget [lindex $arcNodes($arc) 1] + + if {[string equal $oldsource $oldtarget]} return + + set newtarget $oldsource + set newsource $oldtarget + + set arcNodes($arc) [lreplace $arcNodes($arc) 0 0 $newsource] + lappend outArcs($newsource) $arc + ldelete outArcs($oldsource) [lsearch -exact $outArcs($oldsource) $arc] + + set arcNodes($arc) [lreplace $arcNodes($arc) 1 1 $newtarget] + lappend inArcs($newtarget) $arc + ldelete inArcs($oldtarget) [lsearch -exact $inArcs($oldtarget) $arc] + return +} + +# ::struct::graph::__arc_get -- +# +# Get a keyed value from an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# key key to lookup +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__arc_get {name arc key} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this arc, key has to be invalid. + return -code error "invalid key \"$key\" for arc \"$arc\"" + } + + upvar ${name}::$arcAttr($arc) data + if { ![info exists data($key)] } { + return -code error "invalid key \"$key\" for arc \"$arc\"" + } + return $data($key) +} + +# ::struct::graph::__arc_getall -- +# +# Get a serialized array of key/value pairs from an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# pattern optional glob pattern to restrict retrieval +# +# Results: +# value serialized array of key/value pairs. + +proc ::struct::graph::__arc_getall {name arc {pattern *}} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attributes ... + return {} + } + + upvar ${name}::$arcAttr($arc) data + return [array get data $pattern] +} + +# ::struct::graph::__arc_keys -- +# +# Get a list of keys for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# pattern optional glob pattern to restrict retrieval +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__arc_keys {name arc {pattern *}} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attributes ... + return {} + } + + upvar ${name}::$arcAttr($arc) data + return [array names data $pattern] +} + +# ::struct::graph::__arc_keyexists -- +# +# Test for existence of a given key for a given arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# key key to lookup +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::__arc_keyexists {name arc key} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this arc, key cannot exist. + return 0 + } + + upvar ${name}::$arcAttr($arc) data + return [info exists data($key)] +} + +# ::struct::graph::__arc_insert -- +# +# Add an arc to a graph. +# +# Arguments: +# name name of the graph. +# source source node of the new arc +# target target node of the new arc +# args arc to insert; must be unique. If none is given, +# the routine will generate a unique node name. +# +# Results: +# arc The name of the new arc. + +proc ::struct::graph::__arc_insert {name source target args} { + + if { [llength $args] == 0 } { + # No arc name was given; generate a unique one + set arc [__generateUniqueArcName $name] + } elseif { [llength $args] > 1 } { + return {wrong # args: should be "::struct::graph::__arc_insert name source target ?arc?"} + } else { + set arc [lindex $args 0] + } + + CheckDuplicateArc $name $arc + CheckMissingNode $name $source {source } + CheckMissingNode $name $target {target } + + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::arcNodes + + # Set up the new arc + set arcNodes($arc) [list $source $target] + + # Add this arc to the arc lists of its source resp. target nodes. + lappend outArcs($source) $arc + lappend inArcs($target) $arc + + return $arc +} + +# ::struct::graph::__arc_rename -- +# +# Rename a arc in place. +# +# Arguments: +# name name of the graph. +# arc Name of the arc to rename +# newname The new name of the arc. +# +# Results: +# The new name of the arc. + +proc ::struct::graph::__arc_rename {name arc newname} { + CheckMissingArc $name $arc + CheckDuplicateArc $name $newname + + set oldname $arc + + # Perform the rename in the internal + # data structures. + + # - graphAttr - not required, arc independent. + # - nodeAttr - not required, arc independent. + # - counters - not required + + variable ${name}::arcAttr + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::arcNodes + variable ${name}::arcWeight + + # Arc relocation + + set arcNodes($newname) [set nodes $arcNodes($oldname)] + unset arcNodes($oldname) + + # Update the two nodes ... + foreach {start end} $nodes break + + set pos [lsearch -exact $inArcs($end) $oldname] + lset inArcs($end) $pos $newname + + set pos [lsearch -exact $outArcs($start) $oldname] + lset outArcs($start) $pos $newname + + if {[info exists arcAttr($oldname)]} { + set arcAttr($newname) $arcAttr($oldname) + unset arcAttr($oldname) + } + + if {[info exists arcWeight($oldname)]} { + set arcWeight($newname) $arcWeight($oldname) + unset arcWeight($oldname) + } + + return $newname +} + +# ::struct::graph::__arc_set -- +# +# Set or get a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# key attribute to modify or query +# args ?value? +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_set {name arc key args} { + if { [llength $args] > 1 } { + return -code error "wrong # args: should be \"$name arc set arc key ?value?\"" + } + CheckMissingArc $name $arc + + if { [llength $args] > 0 } { + # Setting the value. This may have to create + # the attribute array for this particular + # node + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this node, + # so create it as we need it now. + GenAttributeStorage $name arc $arc + } + + upvar ${name}::$arcAttr($arc) data + return [set data($key) [lindex $args end]] + } else { + # Getting a value + return [__arc_get $name $arc $key] + } +} + +# ::struct::graph::__arc_append -- +# +# Append a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# args key value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_append {name arc key value} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this arc, + # so create it as we need it. + GenAttributeStorage $name arc $arc + } + + upvar ${name}::$arcAttr($arc) data + return [append data($key) $value] +} + +# ::struct::graph::__arc_attr -- +# +# Return attribute data for one key and multiple arcs, possibly all. +# +# Arguments: +# name Name of the graph object. +# key Name of the attribute to retrieve. +# +# Results: +# children Dictionary mapping arcs to attribute data. + +proc ::struct::graph::__arc_attr {name key args} { + # Syntax: + # + # t attr key + # t attr key -arcs {arclist} + # t attr key -glob arcpattern + # t attr key -regexp arcpattern + + variable ${name}::arcAttr + + set usage "wrong # args: should be \"[list $name] arc attr key ?-arcs list|-glob pattern|-regexp pattern?\"" + if {([llength $args] != 0) && ([llength $args] != 2)} { + return -code error $usage + } elseif {[llength $args] == 0} { + # This automatically restricts the list + # to arcs which can have the attribute + # in question. + + set arcs [array names arcAttr] + } else { + # Determine a list of arcs to look at + # based on the chosen restriction. + + foreach {mode value} $args break + switch -exact -- $mode { + -arcs { + # This is the only branch where we have to + # perform an explicit restriction to the + # arcs which have attributes. + set arcs {} + foreach n $value { + if {![info exists arcAttr($n)]} continue + lappend arcs $n + } + } + -glob { + set arcs [array names arcAttr $value] + } + -regexp { + set arcs {} + foreach n [array names arcAttr] { + if {![regexp -- $value $n]} continue + lappend arcs $n + } + } + default { + return -code error "bad type \"$mode\": must be -arcs, -glob, or -regexp" + } + } + } + + # Without possibly matching arcs + # the result has to be empty. + + if {![llength $arcs]} { + return {} + } + + # Now locate matching keys and their values. + + set result {} + foreach n $arcs { + upvar ${name}::$arcAttr($n) data + if {[info exists data($key)]} { + lappend result $n $data($key) + } + } + + return $result +} + +# ::struct::graph::__arc_lappend -- +# +# lappend a value for an arc in a graph. +# +# Arguments: +# name name of the graph. +# arc arc to modify or query. +# args key value +# +# Results: +# val value associated with the given key of the given arc + +proc ::struct::graph::__arc_lappend {name arc key value} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this arc, + # so create it as we need it. + GenAttributeStorage $name arc $arc + } + + upvar ${name}::$arcAttr($arc) data + return [lappend data($key) $value] +} + +# ::struct::graph::__arc_source -- +# +# Return the node at the beginning of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to look up. +# +# Results: +# node name of the node. + +proc ::struct::graph::__arc_source {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcNodes + return [lindex $arcNodes($arc) 0] +} + +# ::struct::graph::__arc_target -- +# +# Return the node at the end of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to look up. +# +# Results: +# node name of the node. + +proc ::struct::graph::__arc_target {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcNodes + return [lindex $arcNodes($arc) 1] +} + +# ::struct::graph::__arc_nodes -- +# +# Return a list containing both source and target nodes of the arc. +# +# Arguments: +# name name of the graph object. +# arc arc to look up. +# +# Results: +# nodes list containing the names of the connected nodes node. +# None + +proc ::struct::graph::__arc_nodes {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcNodes + return $arcNodes($arc) +} + +# ::struct::graph::__arc_move-target -- +# +# Change the destination node of the specified arc. +# The arc is rotated around its origin to a different +# node. +# +# Arguments: +# name name of the graph object. +# arc arc to change. +# newtarget new destination/target of the arc. +# +# Results: +# None + +proc ::struct::graph::__arc_move-target {name arc newtarget} { + CheckMissingArc $name $arc + CheckMissingNode $name $newtarget + + variable ${name}::arcNodes + variable ${name}::inArcs + + set oldtarget [lindex $arcNodes($arc) 1] + if {[string equal $oldtarget $newtarget]} return + + set arcNodes($arc) [lreplace $arcNodes($arc) 1 1 $newtarget] + + lappend inArcs($newtarget) $arc + ldelete inArcs($oldtarget) [lsearch -exact $inArcs($oldtarget) $arc] + return +} + +# ::struct::graph::__arc_move-source -- +# +# Change the origin node of the specified arc. +# The arc is rotated around its destination to a different +# node. +# +# Arguments: +# name name of the graph object. +# arc arc to change. +# newsource new origin/source of the arc. +# +# Results: +# None + +proc ::struct::graph::__arc_move-source {name arc newsource} { + CheckMissingArc $name $arc + CheckMissingNode $name $newsource + + variable ${name}::arcNodes + variable ${name}::outArcs + + set oldsource [lindex $arcNodes($arc) 0] + if {[string equal $oldsource $newsource]} return + + set arcNodes($arc) [lreplace $arcNodes($arc) 0 0 $newsource] + + lappend outArcs($newsource) $arc + ldelete outArcs($oldsource) [lsearch -exact $outArcs($oldsource) $arc] + return +} + +# ::struct::graph::__arc_move -- +# +# Changes both origin and destination node of the specified arc. +# +# Arguments: +# name name of the graph object. +# arc arc to change. +# newsource new origin/source of the arc. +# newtarget new destination/target of the arc. +# +# Results: +# None + +proc ::struct::graph::__arc_move {name arc newsource newtarget} { + CheckMissingArc $name $arc + CheckMissingNode $name $newsource + CheckMissingNode $name $newtarget + + variable ${name}::arcNodes + variable ${name}::outArcs + variable ${name}::inArcs + + set oldsource [lindex $arcNodes($arc) 0] + if {![string equal $oldsource $newsource]} { + set arcNodes($arc) [lreplace $arcNodes($arc) 0 0 $newsource] + lappend outArcs($newsource) $arc + ldelete outArcs($oldsource) [lsearch -exact $outArcs($oldsource) $arc] + } + + set oldtarget [lindex $arcNodes($arc) 1] + if {![string equal $oldtarget $newtarget]} { + set arcNodes($arc) [lreplace $arcNodes($arc) 1 1 $newtarget] + lappend inArcs($newtarget) $arc + ldelete inArcs($oldtarget) [lsearch -exact $inArcs($oldtarget) $arc] + } + return +} + +# ::struct::graph::__arc_unset -- +# +# Remove a keyed value from a arc. +# +# Arguments: +# name name of the graph. +# arc arc to modify. +# key attribute to remove +# +# Results: +# None. + +proc ::struct::graph::__arc_unset {name arc key} { + CheckMissingArc $name $arc + + variable ${name}::arcAttr + if {![info exists arcAttr($arc)]} { + # No attribute data for this arc, + # nothing to do. + return + } + + upvar ${name}::$arcAttr($arc) data + catch {unset data($key)} + + if {[array size data] == 0} { + # No attributes stored for this arc, squash the whole array. + unset arcAttr($arc) + unset data + } + return +} + +# ::struct::graph::__arc_getunweighted -- +# +# Return the arcs which have no weight defined. +# +# Arguments: +# name name of the graph. +# +# Results: +# arcs list of arcs without weights. + +proc ::struct::graph::__arc_getunweighted {name} { + variable ${name}::arcNodes + variable ${name}::arcWeight + return [struct::set difference \ + [array names arcNodes] \ + [array names arcWeight]] +} + +# ::struct::graph::__arc_getweight -- +# +# Get the weight given to an arc in a graph. +# Throws an error if the arc has no weight defined for it. +# +# Arguments: +# name name of the graph. +# arc arc to query. +# +# Results: +# weight The weight defined for the arc. + +proc ::struct::graph::__arc_getweight {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcWeight + if {![info exists arcWeight($arc)]} { + return -code error "arc \"$arc\" has no weight" + } + return $arcWeight($arc) +} + +# ::struct::graph::__arc_setunweighted -- +# +# Define a weight for all arcs which have no weight defined. +# After this call no arc will be unweighted. +# +# Arguments: +# name name of the graph. +# defval weight to give to all unweighted arcs +# +# Results: +# None + +proc ::struct::graph::__arc_setunweighted {name {weight 0}} { + variable ${name}::arcWeight + foreach arc [__arc_getunweighted $name] { + set arcWeight($arc) $weight + } + return +} + +# ::struct::graph::__arc_setweight -- +# +# Define a weight for an arc. +# +# Arguments: +# name name of the graph. +# arc arc to modify +# weight the weight to set for the arc +# +# Results: +# weight The new weight + +proc ::struct::graph::__arc_setweight {name arc weight} { + CheckMissingArc $name $arc + + variable ${name}::arcWeight + set arcWeight($arc) $weight + return $weight +} + +# ::struct::graph::__arc_unsetweight -- +# +# Remove the weight for an arc. +# +# Arguments: +# name name of the graph. +# arc arc to modify +# +# Results: +# None. + +proc ::struct::graph::__arc_unsetweight {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcWeight + if {[info exists arcWeight($arc)]} { + unset arcWeight($arc) + } + return +} + +# ::struct::graph::__arc_hasweight -- +# +# Remove the weight for an arc. +# +# Arguments: +# name name of the graph. +# arc arc to modify +# +# Results: +# None. + +proc ::struct::graph::__arc_hasweight {name arc} { + CheckMissingArc $name $arc + + variable ${name}::arcWeight + return [info exists arcWeight($arc)] +} + +# ::struct::graph::__arc_weights -- +# +# Return the arcs and weights for all arcs which have such. +# +# Arguments: +# name name of the graph. +# +# Results: +# aw dictionary mapping arcs to their weights. + +proc ::struct::graph::__arc_weights {name} { + variable ${name}::arcWeight + return [array get arcWeight] +} + +# ::struct::graph::_arcs -- +# +# Return a list of all arcs in a graph satisfying some +# node based restriction. +# +# Arguments: +# name name of the graph. +# +# Results: +# arcs list of arcs + +proc ::struct::graph::_arcs {name args} { + + CheckE $name arcs $args + + switch -exact -- $cond { + none {set arcs [ArcsNONE $name]} + in {set arcs [ArcsIN $name $condNodes]} + out {set arcs [ArcsOUT $name $condNodes]} + adj {set arcs [ArcsADJ $name $condNodes]} + inner {set arcs [ArcsINN $name $condNodes]} + embedding {set arcs [ArcsEMB $name $condNodes]} + default {return -code error "Can't happen, panic"} + } + + # + # We have a list of arcs that match the relation to the nodes. + # Now filter according to -key and -value. + # + + if {$haveKey && $haveValue} { + set arcs [ArcsKV $name $key $value $arcs] + } elseif {$haveKey} { + set arcs [ArcsK $name $key $arcs] + } + + # + # Apply the general filter command, if specified. + # + + if {$haveFilter} { + lappend fcmd $name + set arcs [uplevel 1 [list ::struct::list filter $arcs $fcmd]] + } + + return $arcs +} + +proc ::struct::graph::ArcsIN {name cn} { + # arcs -in. "Arcs going into the node set" + # + # ARC/in (NS) := { a | target(a) in NS } + + # The result is all arcs going to at least one node in the set + # 'cn' of nodes. + + # As an arc has only one destination, i.e. is the + # in-arc of exactly one node it is impossible to + # count an arc twice. Therefore there is no need + # to keep track of arcs to avoid duplicates. + + variable ${name}::inArcs + + set arcs {} + foreach node $cn { + foreach e $inArcs($node) { + lappend arcs $e + } + } + + return $arcs +} + +proc ::struct::graph::ArcsOUT {name cn} { + # arcs -out. "Arcs coming from the node set" + # + # ARC/out (NS) := { a | source(a) in NS } + + # The result is all arcs coming from at least one node in the list + # of arguments. + + variable ${name}::outArcs + + set arcs {} + foreach node $cn { + foreach e $outArcs($node) { + lappend arcs $e + } + } + + return $arcs +} + +proc ::struct::graph::ArcsADJ {name cn} { + # arcs -adj. "Arcs adjacent to the node set" + # + # ARC/adj (NS) := ARC/in (NS) + ARC/out (NS) + + # Result is all arcs coming from or going to at + # least one node in the list of arguments. + + return [struct::set union \ + [ArcsIN $name $cn] \ + [ArcsOUT $name $cn]] + if 0 { + # Alternate implementation using arrays, + # implementing the set union directly, + # intertwined with the data retrieval. + + array set coll {} + foreach node $condNodes { + foreach e $inArcs($node) { + if {[info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + foreach e $outArcs($node) { + if {[info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + } + } +} + +proc ::struct::graph::ArcsINN {name cn} { + # arcs -adj. "Arcs inside the node set" + # + # ARC/inner (NS) := ARC/in (NS) * ARC/out (NS) + + # Result is all arcs running between nodes + # in the list. + + return [struct::set intersect \ + [ArcsIN $name $cn] \ + [ArcsOUT $name $cn]] + if 0 { + # Alternate implementation using arrays, + # implementing the set intersection + # directly, intertwined with the data + # retrieval. + + array set coll {} + # Here we do need 'coll' as each might be an in- and + # out-arc for one or two nodes in the list of arguments. + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {![info exists group($n)]} {continue} + if { [info exists coll($e)]} {continue} + lappend arcs $e + set coll($e) . + } + # Second iteration over outgoing arcs not + # required. Any arc found above would be found here as + # well, and arcs not recognized above can't be + # recognized by the out loop either. + } + } +} + +proc ::struct::graph::ArcsEMB {name cn} { + # arcs -adj. "Arcs bordering the node set" + # + # ARC/emb (NS) := ARC/inner (NS) - ARC/adj (NS) + # <=> (ARC/in + ARC/out) - (ARC/in * ARC/out) + # <=> (ARC/in - ARC/out) + (ARC/out - ARC/in) + # <=> symmetric difference (ARC/in, ARC/out) + + # Result is all arcs from -adj minus the arcs from -inner. + # IOW all arcs going from a node in the list to a node + # which is *not* in the list + + return [struct::set symdiff \ + [ArcsIN $name $cn] \ + [ArcsOUT $name $cn]] + if 0 { + # Alternate implementation using arrays, + # implementing the set intersection + # directly, intertwined with the data + # retrieval. + + # This also means that no arc can be counted twice as it + # is either going to a node, or coming from a node in the + # list, but it can't do both, because then it is part of + # -inner, which was excluded! + + array set group {} + foreach node $condNodes { + set group($node) . + } + + foreach node $condNodes { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists group($n)]} {continue} + # if {[info exists coll($e)]} {continue} + lappend arcs $e + # set coll($e) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists group($n)]} {continue} + # if {[info exists coll($e)]} {continue} + lappend arcs $e + # set coll($e) . + } + } + } +} + +proc ::struct::graph::ArcsNONE {name} { + variable ${name}::arcNodes + return [array names arcNodes] +} + +proc ::struct::graph::ArcsKV {name key value arcs} { + set filteredArcs {} + foreach arc $arcs { + catch { + set aval [__arc_get $name $arc $key] + if {$aval == $value} { + lappend filteredArcs $arc + } + } + } + return $filteredArcs +} + +proc ::struct::graph::ArcsK {name key arcs} { + set filteredArcs {} + foreach arc $arcs { + catch { + __arc_get $name $arc $key + lappend filteredArcs $arc + } + } + return $filteredArcs +} + +# ::struct::graph::_deserialize -- +# +# Assignment operator. Copies a serialization into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the graph object we are copying into. +# serial Serialized graph to copy from. +# +# Results: +# Nothing. + +proc ::struct::graph::_deserialize {name serial} { + # As we destroy the original graph as part of + # the copying process we don't have to deal + # with issues like node names from the new graph + # interfering with the old ... + + # I. Get the serialization of the source graph + # and check it for validity. + + CheckSerialization $serial \ + gattr nattr aattr ina outa arcn arcw + + # Get all the relevant data into the scope + + variable ${name}::graphAttr + variable ${name}::nodeAttr + variable ${name}::arcAttr + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::arcNodes + variable ${name}::nextAttr + variable ${name}::arcWeight + + # Kill the existing information and insert the new + # data in their place. + + array unset inArcs * + array unset outArcs * + array set inArcs [array get ina] + array set outArcs [array get outa] + unset ina outa + + array unset arcNodes * + array set arcNodes [array get arcn] + unset arcn + + array unset arcWeight * + array set arcWeight [array get arcw] + unset arcw + + set nextAttr 0 + foreach a [array names nodeAttr] { + unset ${name}::$nodeAttr($a) + } + foreach a [array names arcAttr] { + unset ${name}::$arcAttr($a) + } + foreach n [array names nattr] { + GenAttributeStorage $name node $n + array set ${name}::$nodeAttr($n) $nattr($n) + } + foreach a [array names aattr] { + GenAttributeStorage $name arc $a + array set ${name}::$arcAttr($a) $aattr($a) + } + + array unset graphAttr * + array set graphAttr $gattr + + ## Debug ## Dump internals ... + if {0} { + puts "___________________________________ $name" + parray inArcs + parray outArcs + parray arcNodes + parray nodeAttr + parray arcAttr + parray graphAttr + parray arcWeight + puts ___________________________________ + } + return +} + +# ::struct::graph::_destroy -- +# +# Destroy a graph, including its associated command and data storage. +# +# Arguments: +# name name of the graph. +# +# Results: +# None. + +proc ::struct::graph::_destroy {name} { + namespace delete $name + interp alias {} $name {} +} + +# ::struct::graph::__generateUniqueArcName -- +# +# Generate a unique arc name for the given graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# arc name of a arc guaranteed to not exist in the graph. + +proc ::struct::graph::__generateUniqueArcName {name} { + variable ${name}::nextUnusedArc + while {[__arc_exists $name "arc${nextUnusedArc}"]} { + incr nextUnusedArc + } + return "arc${nextUnusedArc}" +} + +# ::struct::graph::__generateUniqueNodeName -- +# +# Generate a unique node name for the given graph. +# +# Arguments: +# name name of the graph. +# +# Results: +# node name of a node guaranteed to not exist in the graph. + +proc ::struct::graph::__generateUniqueNodeName {name} { + variable ${name}::nextUnusedNode + while {[__node_exists $name "node${nextUnusedNode}"]} { + incr nextUnusedNode + } + return "node${nextUnusedNode}" +} + +# ::struct::graph::_get -- +# +# Get a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# key key to lookup +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_get {name key} { + variable ${name}::graphAttr + if { ![info exists graphAttr($key)] } { + return -code error "invalid key \"$key\" for graph \"$name\"" + } + return $graphAttr($key) +} + +# ::struct::graph::_getall -- +# +# Get an attribute dictionary from a graph. +# +# Arguments: +# name name of the graph. +# pattern optional, glob pattern +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_getall {name {pattern *}} { + variable ${name}::graphAttr + return [array get graphAttr $pattern] +} + +# ::struct::graph::_keys -- +# +# Get a list of keys from a graph. +# +# Arguments: +# name name of the graph. +# pattern optional, glob pattern +# +# Results: +# value list of known keys + +proc ::struct::graph::_keys {name {pattern *}} { + variable ${name}::graphAttr + return [array names graphAttr $pattern] +} + +# ::struct::graph::_keyexists -- +# +# Test for existence of a given key in a graph. +# +# Arguments: +# name name of the graph. +# key key to lookup +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::_keyexists {name key} { + variable ${name}::graphAttr + return [info exists graphAttr($key)] +} + +# ::struct::graph::_node -- +# +# Dispatches the invocation of node methods to the proper handler +# procedure. +# +# Arguments: +# name name of the graph. +# cmd node command to invoke +# args arguments to propagate to the handler for the node command +# +# Results: +# As of the the invoked handler. + +proc ::struct::graph::_node {name cmd args} { + # Split the args into command and args components + set sub __node_$cmd + if { [llength [info commands ::struct::graph::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::graph::__node_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 7 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::graph::$sub $name] +} + +# ::struct::graph::__node_degree -- +# +# Return the number of arcs adjacent to the specified node. +# If one of the restrictions -in or -out is given only +# incoming resp. outgoing arcs are counted. +# +# Arguments: +# name name of the graph. +# args option, followed by the node. +# +# Results: +# None. + +proc ::struct::graph::__node_degree {name args} { + + if {([llength $args] < 1) || ([llength $args] > 2)} { + return -code error "wrong # args: should be \"$name node degree ?-in|-out? node\"" + } + + switch -exact -- [llength $args] { + 1 { + set opt {} + set node [lindex $args 0] + } + 2 { + set opt [lindex $args 0] + set node [lindex $args 1] + } + default {return -code error "Can't happen, panic"} + } + + # Validate the option. + + switch -exact -- $opt { + {} - + -in - + -out {} + default { + return -code error "bad option \"$opt\": must be -in or -out" + } + } + + # Validate the node + + CheckMissingNode $name $node + + variable ${name}::inArcs + variable ${name}::outArcs + + switch -exact -- $opt { + -in { + set result [llength $inArcs($node)] + } + -out { + set result [llength $outArcs($node)] + } + {} { + set result [expr {[llength $inArcs($node)] \ + + [llength $outArcs($node)]}] + + # loops count twice, don't do arithmetics, i.e. no union! + if {0} { + array set coll {} + set result [llength $inArcs($node)] + + foreach e $inArcs($node) { + set coll($e) . + } + foreach e $outArcs($node) { + if {[info exists coll($e)]} {continue} + incr result + set coll($e) . + } + } + } + default {return -code error "Can't happen, panic"} + } + + return $result +} + +# ::struct::graph::__node_delete -- +# +# Remove a node from a graph, including all of its values. +# Additionally removes the arcs connected to this node. +# +# Arguments: +# name name of the graph. +# args list of the nodes to delete. +# +# Results: +# None. + +proc ::struct::graph::__node_delete {name args} { + if {![llength $args]} { + return {wrong # args: should be "::struct::graph::__node_delete name node node..."} + } + # seen is used to catch duplicate nodes in the args + array set seen {} + foreach node $args { + if {[info exists seen($node)]} { + return -code error "node \"$node\" does not exist in graph \"$name\"" + } + CheckMissingNode $name $node + set seen($node) . + } + + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::nodeAttr + + foreach node $args { + # Remove all the arcs connected to this node + foreach e $inArcs($node) { + __arc_delete $name $e + } + foreach e $outArcs($node) { + # Check existence to avoid problems with + # loops (they are in and out arcs! at + # the same time and thus already deleted) + if { [__arc_exists $name $e] } { + __arc_delete $name $e + } + } + + unset inArcs($node) + unset outArcs($node) + + if {[info exists nodeAttr($node)]} { + unset ${name}::$nodeAttr($node) + unset nodeAttr($node) + } + } + + return +} + +# ::struct::graph::__node_exists -- +# +# Test for existence of a given node in a graph. +# +# Arguments: +# name name of the graph. +# node node to look for. +# +# Results: +# 1 if the node exists, 0 else. + +proc ::struct::graph::__node_exists {name node} { + return [info exists ${name}::inArcs($node)] +} + +# ::struct::graph::__node_get -- +# +# Get a keyed value from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# key key to lookup +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_get {name node key} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, key has to be invalid. + return -code error "invalid key \"$key\" for node \"$node\"" + } + + upvar ${name}::$nodeAttr($node) data + if { ![info exists data($key)] } { + return -code error "invalid key \"$key\" for node \"$node\"" + } + return $data($key) +} + +# ::struct::graph::__node_getall -- +# +# Get a serialized list of key/value pairs from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# pattern optional glob pattern to restrict retrieval +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_getall {name node {pattern *}} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attributes ... + return {} + } + + upvar ${name}::$nodeAttr($node) data + return [array get data $pattern] +} + +# ::struct::graph::__node_keys -- +# +# Get a list of keys from a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# pattern optional glob pattern to restrict retrieval +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::__node_keys {name node {pattern *}} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attributes ... + return {} + } + + upvar ${name}::$nodeAttr($node) data + return [array names data $pattern] +} + +# ::struct::graph::__node_keyexists -- +# +# Test for existence of a given key for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to query. +# key key to lookup +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::graph::__node_keyexists {name node key} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, key cannot exist. + return 0 + } + + upvar ${name}::$nodeAttr($node) data + return [info exists data($key)] +} + +# ::struct::graph::__node_insert -- +# +# Add a node to a graph. +# +# Arguments: +# name name of the graph. +# args node to insert; must be unique. If none is given, +# the routine will generate a unique node name. +# +# Results: +# node The name of the new node. + +proc ::struct::graph::__node_insert {name args} { + if {[llength $args] == 0} { + # No node name was given; generate a unique one + set args [list [__generateUniqueNodeName $name]] + } else { + # seen is used to catch duplicate nodes in the args + array set seen {} + foreach node $args { + if {[info exists seen($node)]} { + return -code error "node \"$node\" already exists in graph \"$name\"" + } + CheckDuplicateNode $name $node + set seen($node) . + } + } + + variable ${name}::inArcs + variable ${name}::outArcs + + foreach node $args { + # Set up the new node + set inArcs($node) {} + set outArcs($node) {} + } + + return $args +} + +# ::struct::graph::__node_opposite -- +# +# Retrieve node opposite to the specified one, along the arc. +# +# Arguments: +# name name of the graph. +# node node to look up. +# arc arc to look up. +# +# Results: +# nodex Node opposite to + +proc ::struct::graph::__node_opposite {name node arc} { + CheckMissingNode $name $node + CheckMissingArc $name $arc + + variable ${name}::arcNodes + + # Node must be connected to at least one end of the arc. + + if {[string equal $node [lindex $arcNodes($arc) 0]]} { + set result [lindex $arcNodes($arc) 1] + } elseif {[string equal $node [lindex $arcNodes($arc) 1]]} { + set result [lindex $arcNodes($arc) 0] + } else { + return -code error "node \"$node\" and arc \"$arc\" are not connected\ + in graph \"$name\"" + } + + return $result +} + +# ::struct::graph::__node_set -- +# +# Set or get a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# key attribute to modify or query +# args ?value? +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_set {name node key args} { + if { [llength $args] > 1 } { + return -code error "wrong # args: should be \"$name node set node key ?value?\"" + } + CheckMissingNode $name $node + + if { [llength $args] > 0 } { + # Setting the value. This may have to create + # the attribute array for this particular + # node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, + # so create it as we need it now. + GenAttributeStorage $name node $node + } + upvar ${name}::$nodeAttr($node) data + + return [set data($key) [lindex $args end]] + } else { + # Getting a value + return [__node_get $name $node $key] + } +} + +# ::struct::graph::__node_append -- +# +# Append a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# args key value +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_append {name node key value} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name node $node + } + + upvar ${name}::$nodeAttr($node) data + return [append data($key) $value] +} + +# ::struct::graph::__node_attr -- +# +# Return attribute data for one key and multiple nodes, possibly all. +# +# Arguments: +# name Name of the graph object. +# key Name of the attribute to retrieve. +# +# Results: +# children Dictionary mapping nodes to attribute data. + +proc ::struct::graph::__node_attr {name key args} { + # Syntax: + # + # t attr key + # t attr key -nodes {nodelist} + # t attr key -glob nodepattern + # t attr key -regexp nodepattern + + variable ${name}::nodeAttr + + set usage "wrong # args: should be \"[list $name] node attr key ?-nodes list|-glob pattern|-regexp pattern?\"" + if {([llength $args] != 0) && ([llength $args] != 2)} { + return -code error $usage + } elseif {[llength $args] == 0} { + # This automatically restricts the list + # to nodes which can have the attribute + # in question. + + set nodes [array names nodeAttr] + } else { + # Determine a list of nodes to look at + # based on the chosen restriction. + + foreach {mode value} $args break + switch -exact -- $mode { + -nodes { + # This is the only branch where we have to + # perform an explicit restriction to the + # nodes which have attributes. + set nodes {} + foreach n $value { + if {![info exists nodeAttr($n)]} continue + lappend nodes $n + } + } + -glob { + set nodes [array names nodeAttr $value] + } + -regexp { + set nodes {} + foreach n [array names nodeAttr] { + if {![regexp -- $value $n]} continue + lappend nodes $n + } + } + default { + return -code error "bad type \"$mode\": must be -glob, -nodes, or -regexp" + } + } + } + + # Without possibly matching nodes + # the result has to be empty. + + if {![llength $nodes]} { + return {} + } + + # Now locate matching keys and their values. + + set result {} + foreach n $nodes { + upvar ${name}::$nodeAttr($n) data + if {[info exists data($key)]} { + lappend result $n $data($key) + } + } + + return $result +} + +# ::struct::graph::__node_lappend -- +# +# lappend a value for a node in a graph. +# +# Arguments: +# name name of the graph. +# node node to modify or query. +# args key value +# +# Results: +# val value associated with the given key of the given node + +proc ::struct::graph::__node_lappend {name node key value} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name node $node + } + + upvar ${name}::$nodeAttr($node) data + return [lappend data($key) $value] +} + +# ::struct::graph::__node_unset -- +# +# Remove a keyed value from a node. +# +# Arguments: +# name name of the graph. +# node node to modify. +# key attribute to remove +# +# Results: +# None. + +proc ::struct::graph::__node_unset {name node key} { + CheckMissingNode $name $node + + variable ${name}::nodeAttr + if {![info exists nodeAttr($node)]} { + # No attribute data for this node, + # nothing to do. + return + } + + upvar ${name}::$nodeAttr($node) data + catch {unset data($key)} + + if {[array size data] == 0} { + # No attributes stored for this node, squash the whole array. + unset nodeAttr($node) + unset data + } + return +} + +# ::struct::graph::_nodes -- +# +# Return a list of all nodes in a graph satisfying some restriction. +# +# Arguments: +# name name of the graph. +# args list of options and nodes specifying the restriction. +# +# Results: +# nodes list of nodes + +proc ::struct::graph::_nodes {name args} { + + CheckE $name nodes $args + + switch -exact -- $cond { + none {set nodes [NodesNONE $name]} + in {set nodes [NodesIN $name $condNodes]} + out {set nodes [NodesOUT $name $condNodes]} + adj {set nodes [NodesADJ $name $condNodes]} + inner {set nodes [NodesINN $name $condNodes]} + embedding {set nodes [NodesEMB $name $condNodes]} + default {return -code error "Can't happen, panic"} + } + + # + # We have a list of nodes that match the relation to the nodes. + # Now filter according to -key and -value. + # + + if {$haveKey && $haveValue} { + set nodes [NodesKV $name $key $value $nodes] + } elseif {$haveKey} { + set nodes [NodesK $name $key $nodes] + } + + # + # Apply the general filter command, if specified. + # + + if {$haveFilter} { + lappend fcmd $name + set nodes [uplevel 1 [list ::struct::list filter $nodes $fcmd]] + } + + return $nodes +} + +proc ::struct::graph::NodesIN {name cn} { + # nodes -in. + # "Neighbours with arcs going into the node set" + # + # NODES/in (NS) := { source(a) | a in ARC/in (NS) } + + # Result is all nodes with at least one arc going to + # at least one node in the list of arguments. + + variable ${name}::inArcs + variable ${name}::arcNodes + + set nodes {} + array set coll {} + + foreach node $cn { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + return $nodes +} + +proc ::struct::graph::NodesOUT {name cn} { + # nodes -out. + # "Neighbours with arcs coming from the node set" + # + # NODES/out (NS) := { target(a) | a in ARC/out (NS) } + + # Result is all nodes with at least one arc coming from + # at least one node in the list of arguments. + + variable ${name}::outArcs + variable ${name}::arcNodes + + set nodes {} + array set coll {} + + foreach node $cn { + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + return $nodes +} + +proc ::struct::graph::NodesADJ {name cn} { + # nodes -adj. + # "Neighbours of the node set" + # + # NODES/adj (NS) := NODES/in (NS) + NODES/out (NS) + + # Result is all nodes with at least one arc coming from + # or going to at least one node in the list of arguments. + + return [struct::set union \ + [NodesIN $name $cn] \ + [NodesOUT $name $cn]] + if 0 { + # Alternate implementation using arrays, + # implementing the set union directly, + # intertwined with the data retrieval. + + foreach node $cn { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } +} + +proc ::struct::graph::NodesINN {name cn} { + # nodes -adj. + # "Inner node of the node set" + # + # NODES/inner (NS) := NODES/adj (NS) * NS + + # Result is all nodes from the set with at least one arc coming + # from or going to at least one node in the set. + # + # I.e the adjacent nodes also in the set. + + return [struct::set intersect \ + [NodesADJ $name $cn] $cn] + + if 0 { + # Alternate implementation using arrays, + # implementing the set intersect/union + # directly, intertwined with the data retrieval. + + array set group {} + foreach node $cn { + set group($node) . + } + + foreach node $cn { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {![info exists group($n)]} {continue} + if { [info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {![info exists group($n)]} {continue} + if { [info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } +} + +proc ::struct::graph::NodesEMB {name cn} { + # nodes -embedding. + # "Embedding nodes for the node set" + # + # NODES/emb (NS) := NODES/adj (NS) - NS + + # Result is all nodes with at least one arc coming from or going + # to at least one node in the set, but not in the set itself + # + # I.e the adjacent nodes not in the set. + + # Result is all nodes from the set with at least one arc coming + # from or going to at least one node in the set. + # I.e the adjacent nodes still in the set. + + return [struct::set difference \ + [NodesADJ $name $cn] $cn] + + if 0 { + # Alternate implementation using arrays, + # implementing the set diff/union directly, + # intertwined with the data retrieval. + + array set group {} + foreach node $cn { + set group($node) . + } + + foreach node $cn { + foreach e $inArcs($node) { + set n [lindex $arcNodes($e) 0] + if {[info exists group($n)]} {continue} + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + foreach e $outArcs($node) { + set n [lindex $arcNodes($e) 1] + if {[info exists group($n)]} {continue} + if {[info exists coll($n)]} {continue} + lappend nodes $n + set coll($n) . + } + } + } +} + +proc ::struct::graph::NodesNONE {name} { + variable ${name}::inArcs + return [array names inArcs] +} + +proc ::struct::graph::NodesKV {name key value nodes} { + set filteredNodes {} + foreach node $nodes { + catch { + set nval [__node_get $name $node $key] + if {$nval == $value} { + lappend filteredNodes $node + } + } + } + return $filteredNodes +} + +proc ::struct::graph::NodesK {name key nodes} { + set filteredNodes {} + foreach node $nodes { + catch { + __node_get $name $node $key + lappend filteredNodes $node + } + } + return $filteredNodes +} + +# ::struct::graph::__node_rename -- +# +# Rename a node in place. +# +# Arguments: +# name name of the graph. +# node Name of the node to rename +# newname The new name of the node. +# +# Results: +# The new name of the node. + +proc ::struct::graph::__node_rename {name node newname} { + CheckMissingNode $name $node + CheckDuplicateNode $name $newname + + set oldname $node + + # Perform the rename in the internal + # data structures. + + # - graphAttr - not required, node independent. + # - arcAttr - not required, node independent. + # - counters - not required + + variable ${name}::nodeAttr + variable ${name}::inArcs + variable ${name}::outArcs + variable ${name}::arcNodes + + # Node relocation + + set inArcs($newname) [set in $inArcs($oldname)] + unset inArcs($oldname) + set outArcs($newname) [set out $outArcs($oldname)] + unset outArcs($oldname) + + if {[info exists nodeAttr($oldname)]} { + set nodeAttr($newname) $nodeAttr($oldname) + unset nodeAttr($oldname) + } + + # Update all relevant arcs. + # 8.4: lset ... + + foreach a $in { + set arcNodes($a) [list [lindex $arcNodes($a) 0] $newname] + } + foreach a $out { + set arcNodes($a) [list $newname [lindex $arcNodes($a) 1]] + } + + return $newname +} + +# ::struct::graph::_serialize -- +# +# Serialize a graph object (partially) into a transportable value. +# If only a subset of nodes is serialized the result will be a sub- +# graph in the mathematical sense of the word: These nodes and all +# arcs which are only between these nodes. No arcs to modes outside +# of the listed set. +# +# Arguments: +# name Name of the graph. +# args list of nodes to place into the serialized graph +# +# Results: +# A list structure describing the part of the graph which was serialized. + +proc ::struct::graph::_serialize {name args} { + + # all - boolean flag - set if and only if the all nodes of the + # graph are chosen for serialization. Because if that is true we + # can skip the step finding the relevant arcs and simply take all + # arcs. + + variable ${name}::arcNodes + variable ${name}::arcWeight + variable ${name}::inArcs + + set all 0 + if {[llength $args] > 0} { + set nodes [luniq $args] + foreach n $nodes {CheckMissingNode $name $n} + if {[llength $nodes] == [array size inArcs]} { + set all 1 + } + } else { + set nodes [array names inArcs] + set all 1 + } + + if {$all} { + set arcs [array names arcNodes] + } else { + set arcs [eval [linsert $nodes 0 _arcs $name -inner]] + } + + variable ${name}::nodeAttr + variable ${name}::arcAttr + variable ${name}::graphAttr + + set na {} + set aa {} + array set np {} + + # node indices, attribute data ... + set i 0 + foreach n $nodes { + set np($n) [list $i] + incr i 3 + + if {[info exists nodeAttr($n)]} { + upvar ${name}::$nodeAttr($n) data + lappend np($n) [array get data] + } else { + lappend np($n) {} + } + } + + # arc dictionary + set arcdata {} + foreach a $arcs { + foreach {src dst} $arcNodes($a) break + # Arc information + + set arc [list $a] + lappend arc [lindex $np($dst) 0] + if {[info exists arcAttr($a)]} { + upvar ${name}::$arcAttr($a) data + lappend arc [array get data] + } else { + lappend arc {} + } + + # Add weight information, if there is any. + + if {[info exists arcWeight($a)]} { + lappend arc $arcWeight($a) + } + + # Add the information to the node + # indices ... + + lappend np($src) $arc + } + + # Combine the transient data into one result. + + set result [list] + foreach n $nodes { + lappend result $n + lappend result [lindex $np($n) 1] + lappend result [lrange $np($n) 2 end] + } + lappend result [array get graphAttr] + + return $result +} + +# ::struct::graph::_set -- +# +# Set or get a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# key attribute to modify or query +# args ?value? +# +# Results: +# value value associated with the key given. + +proc ::struct::graph::_set {name key args} { + if { [llength $args] > 1 } { + return -code error "wrong # args: should be \"$name set key ?value?\"" + } + if { [llength $args] > 0 } { + variable ${name}::graphAttr + return [set graphAttr($key) [lindex $args end]] + } else { + # Getting a value + return [_get $name $key] + } +} + +# ::struct::graph::_swap -- +# +# Swap two nodes in a graph. +# +# Arguments: +# name name of the graph. +# node1 first node to swap. +# node2 second node to swap. +# +# Results: +# None. + +proc ::struct::graph::_swap {name node1 node2} { + # Can only swap two real nodes + CheckMissingNode $name $node1 + CheckMissingNode $name $node2 + + # Can't swap a node with itself + if { [string equal $node1 $node2] } { + return -code error "cannot swap node \"$node1\" with itself" + } + + # Swapping nodes means swapping their labels, values and arcs + variable ${name}::outArcs + variable ${name}::inArcs + variable ${name}::arcNodes + variable ${name}::nodeAttr + + # Redirect arcs to the new nodes. + + foreach e $inArcs($node1) {lset arcNodes($e) end $node2} + foreach e $inArcs($node2) {lset arcNodes($e) end $node1} + foreach e $outArcs($node1) {lset arcNodes($e) 0 $node2} + foreach e $outArcs($node2) {lset arcNodes($e) 0 $node1} + + # Swap arc lists + + set tmp $inArcs($node1) + set inArcs($node1) $inArcs($node2) + set inArcs($node2) $tmp + + set tmp $outArcs($node1) + set outArcs($node1) $outArcs($node2) + set outArcs($node2) $tmp + + # Swap the values + # More complicated now with the possibility that nodes do not have + # attribute storage associated with them. But also + # simpler as we just have to swap/move the array + # reference + + if { + [set ia [info exists nodeAttr($node1)]] || + [set ib [info exists nodeAttr($node2)]] + } { + # At least one of the nodes has attribute data. We simply swap + # the references to the arrays containing them. No need to + # copy the actual data around. + + if {$ia && $ib} { + set tmp $nodeAttr($node1) + set nodeAttr($node1) $nodeAttr($node2) + set nodeAttr($node2) $tmp + } elseif {$ia} { + set nodeAttr($node2) $nodeAttr($node1) + unset nodeAttr($node1) + } elseif {$ib} { + set nodeAttr($node1) $nodeAttr($node2) + unset nodeAttr($node2) + } else { + return -code error "Impossible condition." + } + } ; # else: No attribute storage => Nothing to do {} + + return +} + +# ::struct::graph::_unset -- +# +# Remove a keyed value from the graph itself +# +# Arguments: +# name name of the graph. +# key attribute to remove +# +# Results: +# None. + +proc ::struct::graph::_unset {name key} { + variable ${name}::graphAttr + if {[info exists graphAttr($key)]} { + unset graphAttr($key) + } + return +} + +# ::struct::graph::_walk -- +# +# Walk a graph using a pre-order depth or breadth first +# search. Pre-order DFS is the default. At each node that is visited, +# a command will be called with the name of the graph and the node. +# +# Arguments: +# name name of the graph. +# node node at which to start. +# args additional args: ?-order pre|post|both? ?-type {bfs|dfs}? +# -command cmd +# +# Results: +# None. + +proc ::struct::graph::_walk {name node args} { + set usage "$name walk node ?-dir forward|backward?\ + ?-order pre|post|both? ?-type bfs|dfs? -command cmd" + + if {[llength $args] < 2} { + return -code error "wrong # args: should be \"$usage\"" + } + + CheckMissingNode $name $node + + # Set defaults + set type dfs + set order pre + set cmd "" + set dir forward + + # Process specified options + for {set i 0} {$i < [llength $args]} {incr i} { + set flag [lindex $args $i] + switch -glob -- $flag { + "-type" { + incr i + if { $i >= [llength $args] } { + return -code error "value for \"$flag\" missing: should be \"$usage\"" + } + set type [string tolower [lindex $args $i]] + } + "-order" { + incr i + if { $i >= [llength $args] } { + return -code error "value for \"$flag\" missing: should be \"$usage\"" + } + set order [string tolower [lindex $args $i]] + } + "-command" { + incr i + if { $i >= [llength $args] } { + return -code error "value for \"$flag\" missing: should be \"$usage\"" + } + set cmd [lindex $args $i] + } + "-dir" { + incr i + if { $i >= [llength $args] } { + return -code error "value for \"$flag\" missing: should be \"$usage\"" + } + set dir [string tolower [lindex $args $i]] + } + default { + return -code error "unknown option \"$flag\": should be \"$usage\"" + } + } + } + + # Make sure we have a command to run, otherwise what's the point? + if { [string equal $cmd ""] } { + return -code error "no command specified: should be \"$usage\"" + } + + # Validate that the given type is good + switch -glob -- $type { + "dfs" { + set type "dfs" + } + "bfs" { + set type "bfs" + } + default { + return -code error "bad search type \"$type\": must be bfs or dfs" + } + } + + # Validate that the given order is good + switch -glob -- $order { + "both" { + set order both + } + "pre" { + set order pre + } + "post" { + set order post + } + default { + return -code error "bad search order \"$order\": must be both,\ + pre, or post" + } + } + + # Validate that the given direction is good + switch -glob -- $dir { + "forward" { + set dir -out + } + "backward" { + set dir -in + } + default { + return -code error "bad search direction \"$dir\": must be\ + backward or forward" + } + } + + # Do the walk + + set st [list ] + lappend st $node + array set visited {} + + if { [string equal $type "dfs"] } { + if { [string equal $order "pre"] } { + # Pre-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + ldelete st end + + # Skip all nodes already visited via some other path + # through the graph. + if {[info exists visited($node)]} continue + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 1 $cmdcpy + + set visited($node) . + + # Add this node's neighbours (according to direction) + # Have to add them in reverse order + # so that they will be popped left-to-right + + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } elseif { [string equal $order "post"] } { + # Post-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are here, pop it, + # then evaluate the command. + + ldelete st end + # Bug 2420330. Note: The visited node may be + # multiple times on the stack (neighbour of more + # than one node). Remove all occurences. + while {[set index [lsearch -exact $st $node]] != -1} { + set st [lreplace $st $index $index] + } + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy leave $name $node + uplevel 1 $cmdcpy + } else { + # First visit. Remember it. + set visited($node) . + + # Add this node's neighbours. + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } + } else { + # Both-order Depth-first search + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are here, pop it, + # then evaluate the command. + + ldelete st end + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy leave $name $node + uplevel 1 $cmdcpy + } else { + # First visit. Remember it. + set visited($node) . + + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 1 $cmdcpy + + # Add this node's neighbours. + set next [_nodes $name $dir $node] + set len [llength $next] + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + set nextnode [lindex $next $i] + if {[info exists visited($nextnode)]} { + # Skip nodes already visited + continue + } + lappend st $nextnode + } + } + } + } + + } else { + if { [string equal $order "pre"] } { + # Pre-order Breadth first search + while { [llength $st] > 0 } { + set node [lindex $st 0] + ldelete st 0 + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy enter $name $node + uplevel 1 $cmdcpy + + set visited($node) . + + # Add this node's neighbours. + foreach child [_nodes $name $dir $node] { + if {[info exists visited($child)]} { + # Skip nodes already visited + continue + } + lappend st $child + } + } + } else { + # Post-order Breadth first search + # Both-order Breadth first search + # Haven't found anything in Knuth + # and unable to define something + # consistent for myself. Leave it + # out. + + return -code error "unable to do a ${order}-order breadth first walk" + } + } + return +} + +# ::struct::graph::Union -- +# +# Return a list which is the union of the elements +# in the specified lists. +# +# Arguments: +# args list of lists representing sets. +# +# Results: +# set list representing the union of the argument lists. + +proc ::struct::graph::Union {args} { + switch -- [llength $args] { + 0 { + return {} + } + 1 { + return [lindex $args 0] + } + default { + foreach set $args { + foreach e $set { + set tmp($e) . + } + } + return [array names tmp] + } + } +} + +# ::struct::graph::GenAttributeStorage -- +# +# Create an array to store the attributes of a node in. +# +# Arguments: +# name Name of the graph containing the node +# type Type of object for the attribute +# obj Name of the node or arc which got attributes. +# +# Results: +# none + +proc ::struct::graph::GenAttributeStorage {name type obj} { + variable ${name}::nextAttr + upvar ${name}::${type}Attr attribute + + set attr "a[incr nextAttr]" + set attribute($obj) $attr + return +} + +proc ::struct::graph::CheckMissingArc {name arc} { + if {![__arc_exists $name $arc]} { + return -code error "arc \"$arc\" does not exist in graph \"$name\"" + } +} + +proc ::struct::graph::CheckMissingNode {name node {prefix {}}} { + if {![__node_exists $name $node]} { + return -code error "${prefix}node \"$node\" does not exist in graph \"$name\"" + } +} + +proc ::struct::graph::CheckDuplicateArc {name arc} { + if {[__arc_exists $name $arc]} { + return -code error "arc \"$arc\" already exists in graph \"$name\"" + } +} + +proc ::struct::graph::CheckDuplicateNode {name node} { + if {[__node_exists $name $node]} { + return -code error "node \"$node\" already exists in graph \"$name\"" + } +} + +proc ::struct::graph::CheckE {name what arguments} { + + # Discriminate between conditions and nodes + + upvar 1 haveCond haveCond ; set haveCond 0 + upvar 1 haveKey haveKey ; set haveKey 0 + upvar 1 key key ; set key {} + upvar 1 haveValue haveValue ; set haveValue 0 + upvar 1 value value ; set value {} + upvar 1 haveFilter haveFilter ; set haveFilter 0 + upvar 1 fcmd fcmd ; set fcmd {} + upvar 1 cond cond ; set cond "none" + upvar 1 condNodes condNodes ; set condNodes {} + + set wa_usage "wrong # args: should be \"$name $what ?-key key? ?-value value? ?-filter cmd? ?-in|-out|-adj|-inner|-embedding node node...?\"" + set seenodes 0 + + for {set i 0} {$i < [llength $arguments]} {incr i} { + set arg [lindex $arguments $i] + switch -glob -- $arg { + -in - + -out - + -adj - + -inner - + -embedding { + if {$haveCond} { + return -code error "invalid restriction:\ + illegal multiple use of\ + \"-in\"|\"-out\"|\"-adj\"|\"-inner\"|\"-embedding\"" + } + + set haveCond 1 + set cond [string range $arg 1 end] + set seenodes 1 + } + -key { + if {($i + 1) == [llength $arguments]} { + return -code error $wa_usage + } + if {$haveKey} { + return -code error {invalid restriction: illegal multiple use of "-key"} + } + + incr i + set key [lindex $arguments $i] + set haveKey 1 + set seenodes 0 + } + -value { + if {($i + 1) == [llength $arguments]} { + return -code error $wa_usage + } + if {$haveValue} { + return -code error {invalid restriction: illegal multiple use of "-value"} + } + + incr i + set value [lindex $arguments $i] + set haveValue 1 + set seenodes 0 + } + -filter { + if {($i + 1) == [llength $arguments]} { + return -code error $wa_usage + } + if {$haveFilter} { + return -code error {invalid restriction: illegal multiple use of "-filter"} + } + + incr i + set fcmd [lindex $arguments $i] + set haveFilter 1 + set seenodes 0 + } + -* { + if {$seenodes} { + lappend condNodes $arg + } else { + return -code error "bad restriction \"$arg\": must be -adj, -embedding,\ + -filter, -in, -inner, -key, -out, or -value" + } + } + default { + lappend condNodes $arg + } + } + } + + # Validate that there are nodes to use in the restriction. + # otherwise what's the point? + if {$haveCond} { + if {[llength $condNodes] == 0} { + return -code error $wa_usage + } + + # Remove duplicates. Note: lsort -unique is not present in Tcl + # 8.2, thus not usable here. + + array set nx {} + foreach c $condNodes {set nx($c) .} + set condNodes [array names nx] + unset nx + + # Make sure that the specified nodes exist! + foreach node $condNodes {CheckMissingNode $name $node} + } + + if {$haveValue && !$haveKey} { + return -code error {invalid restriction: use of "-value" without "-key"} + } + + return +} + +proc ::struct::graph::CheckSerialization {ser gavar navar aavar inavar outavar arcnvar arcwvar} { + upvar 1 \ + $gavar graphAttr \ + $navar nodeAttr \ + $aavar arcAttr \ + $inavar inArcs \ + $outavar outArcs \ + $arcnvar arcNodes \ + $arcwvar arcWeight + + array set nodeAttr {} + array set arcAttr {} + array set inArcs {} + array set outArcs {} + array set arcNodes {} + array set arcWeight {} + + # Overall length ok ? + if {[llength $ser] % 3 != 1} { + return -code error \ + "error in serialization: list length not 1 mod 3." + } + + # Attribute length ok ? Dictionary! + set graphAttr [lindex $ser end] + if {[llength $graphAttr] % 2} { + return -code error \ + "error in serialization: malformed graph attribute dictionary." + } + + # Basic decoder pass + + foreach {node attr narcs} [lrange $ser 0 end-1] { + if {![info exists inArcs($node)]} { + set inArcs($node) [list] + } + set outArcs($node) [list] + + # Attribute length ok ? Dictionary! + if {[llength $attr] % 2} { + return -code error \ + "error in serialization: malformed node attribute dictionary." + } + # Remember attribute data only for non-empty nodes + if {[llength $attr]} { + set nodeAttr($node) $attr + } + + foreach arcd $narcs { + if { + ([llength $arcd] != 3) && + ([llength $arcd] != 4) + } { + return -code error \ + "error in serialization: arc information length not 3 or 4." + } + + foreach {arc dst aattr} $arcd break + + if {[info exists arcNodes($arc)]} { + return -code error \ + "error in serialization: duplicate definition of arc \"$arc\"." + } + + # Attribute length ok ? Dictionary! + if {[llength $aattr] % 2} { + return -code error \ + "error in serialization: malformed arc attribute dictionary." + } + # Remember attribute data only for non-empty nodes + if {[llength $aattr]} { + set arcAttr($arc) $aattr + } + + # Remember weight data if it was specified. + if {[llength $arcd] == 4} { + set arcWeight($arc) [lindex $arcd 3] + } + + # Destination reference ok ? + if { + ![string is integer -strict $dst] || + ($dst % 3) || + ($dst < 0) || + ($dst >= [llength $ser]) + } { + return -code error \ + "error in serialization: bad arc destination reference \"$dst\"." + } + + # Get destination and reconstruct the + # various relationships. + + set dstnode [lindex $ser $dst] + + set arcNodes($arc) [list $node $dstnode] + lappend inArcs($dstnode) $arc + lappend outArcs($node) $arc + } + } + + # Duplicate node names ? + + if {[array size outArcs] < ([llength $ser] / 3)} { + return -code error \ + "error in serialization: duplicate node names." + } + + # Ok. The data is now ready for the caller. + return +} + +########################## +# Private functions follow +# +# Do a compatibility version of [lset] for pre-8.4 versions of Tcl. +# This version does not do multi-arg [lset]! + +proc ::struct::graph::K { x y } { set x } + +if { [package vcompare [package provide Tcl] 8.4] < 0 } { + proc ::struct::graph::lset { var index arg } { + upvar 1 $var list + set list [::lreplace [K $list [set list {}]] $index $index $arg] + } +} + +proc ::struct::graph::ldelete {var index {end {}}} { + upvar 1 $var list + if {$end == {}} {set end $index} + set list [lreplace [K $list [set list {}]] $index $end] + return +} + +proc ::struct::graph::luniq {list} { + array set _ {} + set result [list] + foreach e $list { + if {[info exists _($e)]} {continue} + lappend result $e + set _($e) . + } + return $result +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Put 'graph::graph' into the general structure namespace + # for pickup by the main management. + + namespace import -force graph::graph_tcl +} + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graphops.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graphops.tcl new file mode 100644 index 00000000..b5cb9673 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/graphops.tcl @@ -0,0 +1,3787 @@ +# graphops.tcl -- +# +# Operations on and algorithms for graph data structures. +# +# Copyright (c) 2008 Alejandro Paz , algorithm implementation +# Copyright (c) 2008 Andreas Kupries, integration with Tcllib's struct::graph +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: graphops.tcl,v 1.19 2009/09/24 19:30:10 andreas_kupries Exp $ + +# ### ### ### ######### ######### ######### +## Requisites + +package require Tcl 8.6 9 + +package require struct::disjointset ; # Used by kruskal -- 8.6 required +package require struct::prioqueue ; # Used by kruskal, prim +package require struct::queue ; # Used by isBipartite?, connectedComponent(Of) +package require struct::stack ; # Used by tarjan +package require struct::graph ; # isBridge, isCutVertex +package require struct::tree ; # Used by BFS + +# ### ### ### ######### ######### ######### +## + +namespace eval ::struct::graph::op {} + +# ### ### ### ######### ######### ######### +## + +# This command constructs an adjacency matrix representation of the +# graph argument. + +# Reference: http://en.wikipedia.org/wiki/Adjacency_matrix +# +# Note: The reference defines the matrix in such a way that some of +# the limitations of the code here are not present. I.e. the +# definition at wikipedia deals properly with arc directionality +# and parallelism. +# +# TODO: Rework the code so that the result is in line with the reference. +# Add features to handle weights as well. + +proc ::struct::graph::op::toAdjacencyMatrix {g} { + set nodeList [lsort -dict [$g nodes]] + # Note the lsort. This is used to impose some order on the matrix, + # for comparability of results. Otherwise different versions of + # Tcl and struct::graph (critcl) may generate different, yet + # equivalent matrices, dependent on things like the order a hash + # search is done, or nodes have been added to the graph, or ... + + # Fill an array for index tracking later. Note how we start from + # index 1. This allows us avoid multiple expr+1 later on when + # iterating over the nodes and converting the names to matrix + # indices. See (*). + + set i 1 + foreach n $nodeList { + set nodeDict($n) $i + incr i + } + + set matrix {} + lappend matrix [linsert $nodeList 0 {}] + + # Setting up a template row with all of it's elements set to zero. + + set baseRow 0 + foreach n $nodeList { + lappend baseRow 0 + } + + foreach node $nodeList { + + # The first element in every row is the name of its + # corresponding node. Using lreplace to overwrite the initial + # data in the template we get a copy apart from the template, + # which we can then modify further. + + set currentRow [lreplace $baseRow 0 0 $node] + + # Iterate over the neighbours, also known as 'adjacent' + # rows. The exact set of neighbours depends on the mode. + + foreach neighbour [$g nodes -adj $node] { + # Set value for neighbour on this node list + set at $nodeDict($neighbour) + + # (*) Here we avoid +1 due to starting from index 1 in the + # initialization of nodeDict. + set currentRow [lreplace $currentRow $at $at 1] + } + lappend matrix $currentRow + } + + # The resulting matrix is a list of lists, size (n+1)^2 where n = + # number of nodes. First row and column (index 0) are node + # names. The other entries are boolean flags. True when an arc is + # present, False otherwise. The matrix represents an + # un-directional form of the graph with parallel arcs collapsed. + + return $matrix +} + +#Adjacency List +#------------------------------------------------------------------------------------- +#Procedure creates for graph G, it's representation as Adjacency List. +# +#In comparison to Adjacency Matrix it doesn't force using array with quite big +#size - V^2, where V is a number of vertices ( instead, memory we need is about O(E) ). +#It's especially important when concerning rare graphs ( graphs with amount of vertices +#far bigger than amount of edges ). In practise, it turns out that generally, +#Adjacency List is more effective. Moreover, going through the set of edges take +#less time ( O(E) instead of O(E^2) ) and adding new edges is rapid. +#On the other hand, checking if particular edge exists in graph G takes longer +#( checking if edge {v1,v2} belongs to E(G) in proportion to min{deg(v1,v2)} ). +#Deleting an edge is also longer - in proportion to max{ deg(v1), deg(v2) }. +# +#Input: +# graph G ( directed or undirected ). Default is undirected. +# +#Output: +# Adjacency List for graph G, represented by dictionary containing lists of adjacent nodes +#for each node in G (key). +# +#Options: +# -weights - adds to returning dictionary arc weights for each connection between nodes, so +#each node returned by list as adjacent has additional parameter - weight of arc between him and +#current node. +# -directed - sets graph G to be interpreted as directed graph. +# +#Reference: +#http://en.wikipedia.org/wiki/Adjacency_list +# + +proc ::struct::graph::op::toAdjacencyList {G args} { + + set arcTraversal "undirected" + set weightsOn 0 + + #options for procedure + foreach option $args { + switch -exact -- $option { + -directed { + set arcTraversal "directed" + } + -weights { + #checking if all edges have their weights set + VerifyWeightsAreOk $G + set weightsOn 1 + } + default { + return -code error "Bad option \"$option\". Expected -directed or -weights" + } + } + } + + set V [lsort -dict [$G nodes]] + + #mainloop + switch -exact -- $arcTraversal { + undirected { + #setting up the Adjacency List with nodes + foreach v [lsort -dict [$G nodes]] { + dict set AdjacencyList $v {} + } + #appending the edges adjacent to nodes + foreach e [$G arcs] { + + set v [$G arc source $e] + set u [$G arc target $e] + + if { !$weightsOn } { + dict lappend AdjacencyList $v $u + dict lappend AdjacencyList $u $v + } else { + dict lappend AdjacencyList $v [list $u [$G arc getweight $e]] + dict lappend AdjacencyList $u [list $v [$G arc getweight $e]] + } + } + #deleting duplicated edges + foreach x [dict keys $AdjacencyList] { + dict set AdjacencyList $x [lsort -unique [dict get $AdjacencyList $x]] + } + } + directed { + foreach v $V { + set E [$G arcs -out $v] + set adjNodes {} + foreach e $E { + if { !$weightsOn } { + lappend adjNodes [$G arc target $e] + } else { + lappend adjNodes [list [$G arc target $e] [$G arc getweight $e]] + } + } + dict set AdjacencyList $v $adjNodes + } + } + default { + return -code error "Error while executing procedure" + } + } + + return $AdjacencyList +} + +#Bellman's Ford Algorithm +#------------------------------------------------------------------------------------- +#Searching for shortest paths between chosen node and +#all other nodes in graph G. Based on relaxation method. In comparison to Dijkstra +#it doesn't assume that all weights on edges are positive. However, this generality +#costs us time complexity - O(V*E), where V is number of vertices and E is number +#of edges. +# +#Input: +#Directed graph G, weighted on edges and not containing +#any cycles with negative sum of weights ( the presence of such cycles means +#there is no shortest path, since the total weight becomes lower each time the +#cycle is traversed ). Possible negative weights on edges. +# +#Output: +#dictionary d[u] - distances from start node to each other node in graph G. +# +#Reference: http://en.wikipedia.org/wiki/Bellman-Ford_algorithm +# + +proc ::struct::graph::op::BellmanFord { G startnode } { + + #checking if all edges have their weights set + VerifyWeightsAreOk $G + + #checking if the startnode exists in given graph G + if {![$G node exists $startnode]} { + return -code error "node \"$startnode\" does not exist in graph \"$G\"" + } + + #sets of nodes and edges for graph G + set V [$G nodes] + set E [$G arcs] + + #initialization + foreach i $V { + dict set distances $i Inf + } + + dict set distances $startnode 0 + + #main loop (relaxation) + for { set i 1 } { $i <= ([dict size $distances]-1) } { incr i } { + + foreach j $E { + set u [$G arc source $j] ;# start node of edge j + set v [$G arc target $j] ;# end node of edge j + + if { [ dict get $distances $v ] > [ dict get $distances $u ] + [ $G arc getweight $j ]} { + dict set distances $v [ expr {[dict get $distances $u] + [$G arc getweight $j]} ] + } + } + } + + #checking if there exists cycle with negative sum of weights + foreach i $E { + set u [$G arc source $i] ;# start node of edge i + set v [$G arc target $i] ;# end node of edge i + + if { [dict get $distances $v] > [ dict get $distances $u ] + [$G arc getweight $i] } { + return -code error "Error. Given graph \"$G\" contains cycle with negative sum of weights." + } + } + + return $distances + +} + + +#Johnson's Algorithm +#------------------------------------------------------------------------------------- +#Searching paths between all pairs of vertices in graph. For rare graphs +#asymptotically quicker than Floyd-Warshall's algorithm. Johnson's algorithm +#uses Bellman-Ford's and Dijkstra procedures. +# +#Input: +#Directed graph G, weighted on edges and not containing +#any cycles with negative sum of weights ( the presence of such cycles means +#there is no shortest path, since the total weight becomes lower each time the +#cycle is traversed ). Possible negative weights on edges. +#Possible options: +# -filter ( returns only existing distances, cuts all Inf values for +# non-existing connections between pairs of nodes ) +# +#Output: +# Dictionary containing distances between all pairs of vertices +# +#Reference: http://en.wikipedia.org/wiki/Johnson_algorithm +# + +proc ::struct::graph::op::Johnsons { G args } { + + #options for procedure + set displaymode 0 + foreach option $args { + switch -exact -- $option { + -filter { + set displaymode 1 + } + default { + return -code error "Bad option \"$option\". Expected -filter" + } + } + } + + #checking if all edges have their weights set + VerifyWeightsAreOk $G + + #Transformation of graph G - adding one more node connected with + #each existing node with an edge, which weight is 0 + set V [$G nodes] + set s [$G node insert] + + foreach i $V { + if { $i ne $s } { + $G arc insert $s $i + } + } + + $G arc setunweighted + + #set potential values with Bellman-Ford's + set h [BellmanFord $G $s] + + #transformed graph no needed longer - deleting added node and edges + $G node delete $s + + #setting new weights for edges in graph G + foreach i [$G arcs] { + set u [$G arc source $i] + set v [$G arc target $i] + + lappend weights [$G arc getweight $i] + $G arc setweight $i [ expr { [$G arc getweight $i] + [dict get $h $u] - [dict get $h $v] } ] + } + + #finding distances between all pair of nodes with Dijkstra started from each node + foreach i [$G nodes] { + set dijkstra [dijkstra $G $i -arcmode directed -outputformat distances] + + foreach j [$G nodes] { + if { $i ne $j } { + if { $displaymode eq 1 } { + if { [dict get $dijkstra $j] ne "Inf" } { + dict set values [list $i $j] [ expr {[ dict get $dijkstra $j] - [dict get $h $i] + [dict get $h $j]} ] + } + } else { + dict set values [list $i $j] [ expr {[ dict get $dijkstra $j] - [dict get $h $i] + [dict get $h $j]} ] + } + } + } + } + + #setting back edge weights for graph G + set k 0 + foreach i [$G arcs] { + $G arc setweight $i [ lindex $weights $k ] + incr k + } + + return $values +} + + +#Floyd-Warshall's Algorithm +#------------------------------------------------------------------------------------- +#Searching shortest paths between all pairs of edges in weighted graphs. +#Time complexity: O(V^3) - where V is number of vertices. +#Memory complexity: O(V^2) +#Input: directed weighted graph G +#Output: dictionary containing shortest distances to each node from each node +# +#Algorithm finds solutions dynamically. It compares all possible paths through the graph +#between each pair of vertices. Graph shouldn't possess any cycle with negative +#sum of weights ( the presence of such cycles means there is no shortest path, +#since the total weight becomes lower each time the cycle is traversed ). +#On the other hand algorithm can be used to find those cycles - if any shortest distance +#found by algorithm for any nodes v and u (when v is the same node as u) is negative, +#that node surely belong to at least one negative cycle. +# +#Reference: http://en.wikipedia.org/wiki/Floyd-Warshall_algorithm +# + +proc ::struct::graph::op::FloydWarshall { G } { + + VerifyWeightsAreOk $G + + foreach v1 [$G nodes] { + foreach v2 [$G nodes] { + dict set values [list $v1 $v2] Inf + } + dict set values [list $v1 $v1] 0 + } + + foreach e [$G arcs] { + set v1 [$G arc source $e] + set v2 [$G arc target $e] + dict set values [list $v1 $v2] [$G arc getweight $e] + } + + foreach u [$G nodes] { + foreach v1 [$G nodes] { + foreach v2 [$G nodes] { + + set x [dict get $values [list $v1 $u]] + set y [dict get $values [list $u $v2]] + set d [ expr {$x + $y}] + + if { [dict get $values [list $v1 $v2]] > $d } { + dict set values [list $v1 $v2] $d + } + } + } + } + #finding negative cycles + foreach v [$G nodes] { + if { [dict get $values [list $v $v]] < 0 } { + return -code error "Error. Given graph \"$G\" contains cycle with negative sum of weights." + } + } + + return $values +} + +#Metric Travelling Salesman Problem (TSP) - 2 approximation algorithm +#------------------------------------------------------------------------------------- +#Travelling salesman problem is a very popular problem in graph theory, where +#we are trying to find minimal Hamilton cycle in weighted complete graph. In other words: +#given a list of cities (nodes) and their pairwise distances (edges), the task is to find +#a shortest possible tour that visits each city exactly once. +#TSP problem is NP-Complete, so there is no efficient algorithm to solve it. Greedy methods +#are getting extremely slow, with the increase in the set of nodes. +# +#For this algorithm we consider a case when for given graph G, the triangle inequality is +#satisfied. So for example, for any three nodes A, B and C the distance between A and C must +#be at most the distance from A to B plus the distance from B to C. What's important +#most of the considered cases in TSP problem will satisfy this condition. +# +#Input: undirected, weighted graph G +#Output: approximated solution of minimum Hamilton Cycle - closed path visiting all nodes, +#each exactly one time. +# +#Reference: http://en.wikipedia.org/wiki/Travelling_salesman_problem +# + +proc ::struct::graph::op::MetricTravellingSalesman { G } { + + #checking if graph is connected + if { ![isConnected? $G] } { + return -code error "Error. Given graph \"$G\" is not a connected graph." + } + #checking if all weights are set + VerifyWeightsAreOk $G + + # Extend graph to make it complete. + # NOTE: The graph is modified in place. + createCompleteGraph $G originalEdges + + #create minimum spanning tree for graph G + set T [prim $G] + + #TGraph - spanning tree of graph G + #filling TGraph with edges and nodes + set TGraph [createTGraph $G $T 0] + + #finding Hamilton cycle + set result [findHamiltonCycle $TGraph $originalEdges $G] + + $TGraph destroy + + # Note: Fleury, which is the algorithm used to find our the cycle + # (inside of isEulerian?) is inherently directionless, i.e. it + # doesn't care about arc direction. This does not matter if our + # input is a symmetric graph, i.e. u->v and v->u have the same + # weight for all nodes u, v in G, u != v. But for an asymmetric + # graph as our input we really have to check the two possible + # directions of the returned tour for the one with the smaller + # weight. See test case MetricTravellingSalesman-1.1 for an + # exmaple. + + set w {} + foreach a [$G arcs] { + set u [$G arc source $a] + set v [$G arc target $a] + set uv [list $u $v] + # uv = <$G arc nodes $arc> + dict set w $uv [$G arc getweight $a] + } + foreach k [dict keys $w] { + lassign $k u v + set vu [list $v $u] + if {[dict exists $w $vu]} continue + dict set w $vu [dict get $w $k] + } + + set reversed [lreverse $result] + + if {[TourWeight $w $result] > [TourWeight $w $reversed]} { + return $reversed + } + return $result +} + +proc ::struct::graph::op::TourWeight {w tour} { + set total 0 + foreach \ + u [lrange $tour 0 end-1] \ + v [lrange $tour 1 end] { + set uv [list $u $v] + set total [expr { + $total + + [dict get $w $uv] + }] + } + return $total +} + +#Christofides Algorithm - for Metric Travelling Salesman Problem (TSP) +#------------------------------------------------------------------------------------- +#Travelling salesman problem is a very popular problem in graph theory, where +#we are trying to find minimal Hamilton cycle in weighted complete graph. In other words: +#given a list of cities (nodes) and their pairwise distances (edges), the task is to find +#a shortest possible tour that visits each city exactly once. +#TSP problem is NP-Complete, so there is no efficient algorithm to solve it. Greedy methods +#are getting extremely slow, with the increase in the set of nodes. +# +#For this algorithm we consider a case when for given graph G, the triangle inequality is +#satisfied. So for example, for any three nodes A, B and C the distance between A and C must +#be at most the distance from A to B plus the distance from B to C. What's important +#most of the considered cases in TSP problem will satisfy this condition. +# +#Christofides is a 3/2 approximation algorithm. For a graph given at input, it returns +#found Hamilton cycle (list of nodes). +# +#Reference: http://en.wikipedia.org/wiki/Christofides_algorithm +# + +proc ::struct::graph::op::Christofides { G } { + + #checking if graph is connected + if { ![isConnected? $G] } { + return -code error "Error. Given graph \"$G\" is not a connected graph." + } + #checking if all weights are set + VerifyWeightsAreOk $G + + createCompleteGraph $G originalEdges + + #create minimum spanning tree for graph G + set T [prim $G] + + #setting graph algorithm is working on - spanning tree of graph G + set TGraph [createTGraph $G $T 1] + + set oddTGraph [struct::graph] + + foreach v [$TGraph nodes] { + if { [$TGraph node degree $v] % 2 == 1 } { + $oddTGraph node insert $v + } + } + + #create complete graph + foreach v [$oddTGraph nodes] { + foreach u [$oddTGraph nodes] { + if { ($u ne $v) && ![$oddTGraph arc exists [list $u $v]] } { + $oddTGraph arc insert $v $u [list $v $u] + $oddTGraph arc setweight [list $v $u] [distance $G $v $u] + } + + } + } + + #### + # MAX MATCHING HERE!!! + #### + set M [GreedyMaxMatching $oddTGraph] + + foreach e [$oddTGraph arcs] { + if { ![struct::set contains $M $e] } { + $oddTGraph arc delete $e + } + } + + #operation: M + T + foreach e [$oddTGraph arcs] { + set u [$oddTGraph arc source $e] + set v [$oddTGraph arc target $e] + set uv [list $u $v] + + # Check if the arc in max-matching is parallel or not, to make + # sure that we always insert an anti-parallel arc. + + if {[$TGraph arc exists $uv]} { + set vu [list $v $u] + $TGraph arc insert $v $u $vu + $TGraph arc setweight $vu [$oddTGraph arc getweight $e] + } else { + $TGraph arc insert $u $v $uv + $TGraph arc setweight $uv [$oddTGraph arc getweight $e] + } + } + + #finding Hamilton Cycle + set result [findHamiltonCycle $TGraph $originalEdges $G] + $oddTGraph destroy + $TGraph destroy + return $result +} + +#Greedy Max Matching procedure, which finds maximal ( not maximum ) matching +#for given graph G. It adds edges to solution, beginning from edges with the +#lowest cost. + +proc ::struct::graph::op::GreedyMaxMatching {G} { + + set maxMatch {} + + foreach e [sortEdges $G] { + set v [$G arc source $e] + set u [$G arc target $e] + set neighbours [$G arcs -adj $v $u] + set noAdjacentArcs 1 + + lremove neighbours $e + + foreach a $neighbours { + if { $a in $maxMatch } { + set noAdjacentArcs 0 + break + } + } + if { $noAdjacentArcs } { + lappend maxMatch $e + } + } + + return $maxMatch +} + +#Subprocedure which for given graph G, returns the set of edges +#sorted with their costs. +proc ::struct::graph::op::sortEdges {G} { + set weights [$G arc weights] + + # NOTE: Look at possible rewrite, simplification. + + set sortedEdges {} + + foreach val [lsort [dict values $weights]] { + foreach x [dict keys $weights] { + if { [dict get $weights $x] == $val } { + set weights [dict remove $weights $x] + lappend sortedEdges $x ;#[list $val $x] + } + } + } + + return $sortedEdges +} + +#Subprocedure, which for given graph G, returns the dictionary +#containing edges sorted by weights (sortMode -> weights) or +#nodes sorted by degree (sortMode -> degrees). + +proc ::struct::graph::op::sortGraph {G sortMode} { + + switch -exact -- $sortMode { + weights { + set weights [$G arc weights] + foreach val [lsort [dict values $weights]] { + foreach x [dict keys $weights] { + if { [dict get $weights $x] == $val } { + set weights [dict remove $weights $x] + dict set sortedVals $x $val + } + } + } + } + degrees { + foreach v [$G nodes] { + dict set degrees $v [$G node degree $v] + } + foreach x [lsort -integer -decreasing [dict values $degrees]] { + foreach y [dict keys $degrees] { + if { [dict get $degrees $y] == $x } { + set degrees [dict remove $degrees $y] + dict set sortedVals $y $x + } + } + } + } + default { + return -code error "Unknown sort mode \"$sortMode\", expected weights, or degrees" + } + } + + return $sortedVals +} + +#Finds Hamilton cycle in given graph G +#Procedure used by Metric TSP Algorithms: +#Christofides and Metric TSP 2-approximation algorithm + +proc ::struct::graph::op::findHamiltonCycle {G originalEdges originalGraph} { + + isEulerian? $G tourvar tourstart + + # Note: The start node is not necessarily the source node of the + # first arc in the tour. The Fleury in isEulerian? may have walked + # the arcs against! their direction. See also the note in our + # caller (MetricTravellingSalesman). + + # Instead of reconstructing the start node by intersecting the + # node-set for first and last arc, we are taking the easy and get + # it directly from isEulerian?, as that command knows which node + # it had chosen for this. + + lappend result $tourstart + lappend tourvar [lindex $tourvar 0] + + set v $tourstart + foreach i $tourvar { + set u [$G node opposite $v $i] + + if { $u ni $result } { + set va [lindex $result end] + set vb $u + + if { ([list $va $vb] in $originalEdges) || ([list $vb $va] in $originalEdges) } { + lappend result $u + } else { + + set path [dict get [dijkstra $G $va] $vb] + + #reversing the path + set path [lreverse $path] + #cutting the start element + set path [lrange $path 1 end] + + #adding the path and the target element + lappend result {*}$path + lappend result $vb + } + } + set v $u + } + + set path [dict get [dijkstra $originalGraph [lindex $result 0]] [lindex $result end]] + set path [lreverse $path] + + set path [lrange $path 1 end] + + if { [llength $path] } { + lappend result {*}$path + } + + lappend result $tourstart + return $result +} + +#Subprocedure for TSP problems. +# +#Creating graph from sets of given nodes and edges. +#In option doubledArcs we decide, if we want edges to be +#duplicated or not: +#0 - duplicated (Metric TSP 2-approximation algorithm) +#1 - single (Christofides Algorithm) +# +#Note that it assumes that graph's edges are properly weighted. That +#condition is checked before in procedures that use createTGraph, but for +#other uses it should be taken into consideration. +# + +proc ::struct::graph::op::createTGraph {G Edges doubledArcs} { + #checking if given set of edges is proper (all edges are in graph G) + foreach e $Edges { + if { ![$G arc exists $e] } { + return -code error "Edge \"$e\" doesn't exist in graph \"$G\". Set the proper set of edges." + } + } + + set TGraph [struct::graph] + + #fill TGraph with nodes + foreach v [$G nodes] { + $TGraph node insert + } + + #fill TGraph with arcs + foreach e $Edges { + set v [$G arc source $e] + set u [$G arc target $e] + if { ![$TGraph arc exists [list $u $v]] } { + $TGraph arc insert $u $v [list $u $v] + $TGraph arc setweight [list $u $v] [$G arc getweight $e] + } + if { !$doubledArcs } { + if { ![$TGraph arc exists [list $v $u]] } { + $TGraph arc insert $v $u [list $v $u] + $TGraph arc setweight [list $v $u] [$G arc getweight $e] + } + } + } + + return $TGraph +} + +#Subprocedure for some algorithms, e.g. TSP algorithms. +# +#It returns graph filled with arcs missing to say that graph is complete. +#Also it sets variable originalEdges with edges, which existed in given +#graph G at beginning, before extending the set of edges. +# + +proc ::struct::graph::op::createCompleteGraph {G originalEdges} { + + upvar $originalEdges st + set st {} + foreach e [$G arcs] { + set v [$G arc source $e] + set u [$G arc target $e] + + lappend st [list $v $u] + } + + foreach v [$G nodes] { + foreach u [$G nodes] { + if { ($u != $v) && ([list $v $u] ni $st) && ([list $u $v] ni $st) && ![$G arc exists [list $u $v]] } { + $G arc insert $v $u [list $v $u] + $G arc setweight [list $v $u] Inf + } + } + } + return $G +} + + +#Maximum Cut - 2 approximation algorithm +#------------------------------------------------------------------------------------- +#Maximum cut problem is a problem finding a cut not smaller than any other cut. In +#other words, we divide set of nodes for graph G into such 2 sets of nodes U and V, +#that the amount of edges connecting U and V is as high as possible. +# +#Algorithm is a 2-approximation, so for ALG ( solution returned by Algorithm) and +#OPT ( optimal solution), such inequality is true: OPT <= 2 * ALG. +# +#Input: +#Graph G +#U - variable storing first set of nodes (cut) given by solution +#V - variable storing second set of nodes (cut) given by solution +# +#Output: +#Algorithm returns number of edges between found two sets of nodes. +# +#Reference: http://en.wikipedia.org/wiki/Maxcut +# + +proc ::struct::graph::op::MaxCut {G U V} { + + upvar $U _U + upvar $V _V + + set _U {} + set _V {} + set counter 0 + + foreach {u v} [lsort -dict [$G nodes]] { + lappend _U $u + if {$v eq ""} continue + lappend _V $v + } + + set val 1 + set ALG [countEdges $G $_U $_V] + while {$val>0} { + set val [cut $G _U _V $ALG] + if { $val > $ALG } { + set ALG $val + } + } + return $ALG +} + +#procedure replaces nodes between sets and checks if that change is profitable +proc ::struct::graph::op::cut {G Uvar Vvar param} { + + upvar $Uvar U + upvar $Vvar V + set _V {} + set _U {} + set value 0 + + set maxValue $param + set _U $U + set _V $V + + foreach v [$G nodes] { + + if { $v ni $_U } { + lappend _U $v + lremove _V $v + set value [countEdges $G $_U $_V] + } else { + lappend _V $v + lremove _U $v + set value [countEdges $G $_U $_V] + } + + if { $value > $maxValue } { + set U $_U + set V $_V + set maxValue $value + } else { + set _V $V + set _U $U + } + } + + set value $maxValue + + if { $value > $param } { + return $value + } else { + return 0 + } +} + +#Removing element from the list - auxiliary procedure +proc ::struct::graph::op::lremove {listVariable value} { + upvar 1 $listVariable var + set idx [lsearch -exact $var $value] + set var [lreplace $var $idx $idx] +} + +#procedure counts edges that link two sets of nodes +proc ::struct::graph::op::countEdges {G U V} { + + set value 0 + + foreach u $U { + foreach e [$G arcs -out $u] { + set v [$G arc target $e] + if {$v ni $V} continue + incr value + } + } + foreach v $V { + foreach e [$G arcs -out $v] { + set u [$G arc target $e] + if {$u ni $U} continue + incr value + } + } + + return $value +} + +#K-Center Problem - 2 approximation algorithm +#------------------------------------------------------------------------------------- +#Input: +#Undirected complete graph G, which satisfies triangle inequality. +#k - positive integer +# +#Definition: +#For any set S ( which is subset of V ) and node v, let the connect(v,S) be the +#cost of cheapest edge connecting v with any node in S. The goal is to find +#such S, that |S| = k and max_v{connect(v,S)} is possibly small. +# +#In other words, we can use it i.e. for finding best locations in the city ( nodes +#of input graph ) for placing k buildings, such that those buildings will be as close +#as possible to all other locations in town. +# +#Output: +#set of nodes - k center for graph G +# + +proc ::struct::graph::op::UnweightedKCenter {G k} { + + #checking if all weights for edges in graph G are set well + VerifyWeightsAreOk $G + + #checking if proper value of k is given at input + if { $k <= 0 } { + return -code error "The \"k\" value must be an positive integer." + } + + set j [ expr {$k+1} ] + + #variable for holding the graph G(i) in each iteration + set Gi [struct::graph] + #two squared graph G + set GiSQ [struct::graph] + #sorted set of edges for graph G + set arcs [sortEdges $G] + + #initializing both graph variables + foreach v [$G nodes] { + $Gi node insert $v + $GiSQ node insert $v + } + + #index i for each iteration + + #we seek for final solution, as long as the max independent + #set Mi (found in particular iterations), such that |Mi| <= k, is found. + for {set index 0} {$j > $k} {incr index} { + #source node of an edge we add in current iteration + set u [$G arc source [lindex $arcs $index]] + #target node of an edge we add in current iteration + set v [$G arc target [lindex $arcs $index]] + + #adding edge Ei to graph G(i) + $Gi arc insert $u $v [list $u $v] + #extending G(i-1)**2 to G(i)**2 using G(i) + set GiSQ [extendTwoSquaredGraph $GiSQ $Gi $u $v] + + #finding maximal independent set for G(i)**2 + set Mi [GreedyMaxIndependentSet $GiSQ] + + #number of nodes in maximal independent set that was found + set j [llength $Mi] + } + + $Gi destroy + $GiSQ destroy + return $Mi +} + +#Weighted K-Center - 3 approximation algorithm +#------------------------------------------------------------------------------------- +# +#The variation of unweighted k-center problem. Besides the fact graph is edge-weighted, +#there are also weights on vertices of input graph G. We've got also restriction +#W. The goal is to choose such set of nodes S ( which is a subset of V ), that it's +#total weight is not greater than W and also function: max_v { min_u { cost(u,v) }} +#has the smallest possible worth ( v is a node in V and u is a node in S ). +# +#Note: +#For more information about K-Center problem check Unweighted K-Center algorithm +#description. + +proc ::struct::graph::op::WeightedKCenter {G nodeWeights W} { + + #checking if all weights for edges in graph G are set well + VerifyWeightsAreOk $G + + #checking if proper value of k is given at input + if { $W <= 0 } { + return -code error "The \"W\" value must be an positive integer." + } + #initilization + set j [ expr {$W+1} ] + + #graphs G(i) and G(i)**2 + set Gi [struct::graph] + set GiSQ [struct::graph] + #the set of arcs for graph G sorted with their weights (increasing) + set arcs [sortEdges $G] + + #initialization of graphs G(i) and G(i)**2 + foreach v [$G nodes] { + $Gi node insert $v + $GiSQ node insert $v + } + + #the main loop - iteration over all G(i)'s and G(i)**2's, + #extended with each iteration till the solution is found + + foreach arc $arcs { + #initilization of the set of nodes, which are cheapest neighbours + #for particular nodes in maximal independent set + set Si {} + + set u [$G arc source $arc] + set v [$G arc target $arc] + + #extending graph G(i) + $Gi arc insert $u $v [list $u $v] + + #extending graph G(i)**2 from G(i-1)**2 using G(i) + set GiSQ [extendTwoSquaredGraph $GiSQ $Gi $u $v] + + #finding maximal independent set (Mi) for graph G(i)**2 found in the + #previous step. Mi is found using greedy algorithm that also considers + #weights on vertices. + set Mi [GreedyWeightedMaxIndependentSet $GiSQ $nodeWeights] + + #for each node u in Maximal Independent set found in previous step, + #we search for its cheapest ( considering costs at vertices ) neighbour. + #Note that node u is considered as it is a neighbour for itself. + foreach u $Mi { + + set minWeightOfSi Inf + + #the neighbours of u + set neighbours [$Gi nodes -adj $u] + set smallestNeighbour 0 + #u is a neighbour for itself + lappend neighbours $u + + #finding neighbour with minimal cost + foreach w [lsort -index 1 $nodeWeights] { + lassign $w node weight + if {[struct::set contains $neighbours $node]} { + set minWeightOfSi $weight + set smallestNeighbour $node + break + } + } + + lappend Si [list $smallestNeighbour $minWeightOfSi] + } + + set totalSiWeight 0 + set possibleSolution {} + + foreach s $Si { + #counting the total weight of the set of nodes - Si + set totalSiWeight [ expr { $totalSiWeight + [lindex $s 1] } ] + + #it's final solution, if weight found in previous step is + #not greater than W + lappend possibleSolution [lindex $s 0] + } + + #checking if final solution is found + if { $totalSiWeight <= $W } { + $Gi destroy + $GiSQ destroy + return $possibleSolution + } + } + + $Gi destroy + $GiSQ destroy + + #no solution found - error returned + return -code error "No k-center found for restriction W = $W" + +} + +#Maximal Independent Set - 2 approximation greedy algorithm +#------------------------------------------------------------------------------------- +# +#A maximal independent set is an independent set such that adding any other node +#to the set forces the set to contain an edge. +# +#Note: +#Don't confuse it with maximum independent set, which is a largest independent set +#for a given graph G. +# +#Reference: http://en.wikipedia.org/wiki/Maximal_independent_set + +proc ::struct::graph::op::GreedyMaxIndependentSet {G} { + + set result {} + set nodes [$G nodes] + + foreach v $nodes { + if { [struct::set contains $nodes $v] } { + lappend result $v + + foreach neighbour [$G nodes -adj $v] { + struct::set exclude nodes $neighbour + } + } + } + + return $result +} + +#Weighted Maximal Independent Set - 2 approximation greedy algorithm +#------------------------------------------------------------------------------------- +# +#Weighted variation of Maximal Independent Set. It takes as an input argument +#not only graph G but also set of weights for all vertices in graph G. +# +#Note: +#Read also Maximal Independent Set description for more info. +# +#Reference: http://en.wikipedia.org/wiki/Maximal_independent_set + +proc ::struct::graph::op::GreedyWeightedMaxIndependentSet {G nodeWeights} { + + set result {} + set nodes {} + foreach v [lsort -index 1 $nodeWeights] { + lappend nodes [lindex $v 0] + } + + foreach v $nodes { + if { [struct::set contains $nodes $v] } { + lappend result $v + + set neighbours [$G nodes -adj $v] + + foreach neighbour [$G nodes -adj $v] { + struct::set exclude nodes $neighbour + } + } + } + + return $result +} + +#subprocedure creating from graph G two squared graph +#G^2 - graph in which edge between nodes u and v exists, +#if and only if, when distance (in edges, not weights) +#between those nodes is not greater than 2 and u != v. + +proc ::struct::graph::op::createSquaredGraph {G} { + + set H [struct::graph] + foreach v [$G nodes] { + $H node insert $v + } + + foreach v [$G nodes] { + foreach u [$G nodes -adj $v] { + if { ($v != $u) && ![$H arc exists [list $v $u]] && ![$H arc exists [list $u $v]] } { + $H arc insert $u $v [list $u $v] + } + foreach z [$G nodes -adj $u] { + if { ($v != $z) && ![$H arc exists [list $v $z]] && ![$H arc exists [list $z $v]] } { + $H arc insert $v $z [list $v $z] + } + } + } + } + + return $H +} + +#subprocedure for Metric K-Center problem +# +#Input: +#previousGsq - graph G(i-1)**2 +#currentGi - graph G(i) +#u and v - source and target of an edge added in this iteration +# +#Output: +#Graph G(i)**2 used by next steps of K-Center algorithm + +proc ::struct::graph::op::extendTwoSquaredGraph {previousGsq currentGi u v} { + + #adding new edge + if { ![$previousGsq arc exists [list $v $u]] && ![$previousGsq arc exists [list $u $v]]} { + $previousGsq arc insert $u $v [list $u $v] + } + + #adding new edges to solution graph: + #here edges, where source is a $u node and targets are neighbours of node $u except for $v + foreach x [$currentGi nodes -adj $u] { + if { ( $x != $v) && ![$previousGsq arc exists [list $v $x]] && ![$previousGsq arc exists [list $x $v]] } { + $previousGsq arc insert $v $x [list $v $x] + } + } + #here edges, where source is a $v node and targets are neighbours of node $v except for $u + foreach x [$currentGi nodes -adj $v] { + if { ( $x != $u ) && ![$previousGsq arc exists [list $u $x]] && ![$previousGsq arc exists [list $x $u]] } { + $previousGsq arc insert $u $x [list $u $x] + } + } + + return $previousGsq +} + +#Vertices Cover - 2 approximation algorithm +#------------------------------------------------------------------------------------- +#Vertices cover is a set o vertices such that each edge of the graph is incident to +#at least one vertex of the set. This 2-approximation algorithm searches for minimum +#vertices cover, which is a classical optimization problem in computer science and +#is a typical example of an NP-hard optimization problem that has an approximation +#algorithm. +# +#Reference: http://en.wikipedia.org/wiki/Vertex_cover_problem +# + +proc ::struct::graph::op::VerticesCover {G} { + #variable containing final solution + set vc {} + #variable containing sorted (with degree) set of arcs for graph G + set arcs {} + + #setting the dictionary with degrees for each node + foreach v [$G nodes] { + dict set degrees $v [$G node degree $v] + } + + #creating a list containing the sum of degrees for source and + #target nodes for each edge in graph G + foreach e [$G arcs] { + set v [$G arc source $e] + set u [$G arc target $e] + + lappend values [list [expr {[dict get $degrees $v]+[dict get $degrees $u]}] $e] + } + #sorting the list of source and target degrees + set values [lsort -integer -decreasing -index 0 $values] + + #setting the set of edges in a right sequence + foreach e $values { + lappend arcs [lindex $e 1] + } + + #for each node in graph G, we add it to the final solution and + #erase all arcs adjacent to it, so they cannot be + #added to solution in next iterations + foreach e $arcs { + + if { [struct::set contains $arcs $e] } { + set v [$G arc source $e] + set u [$G arc target $e] + lappend vc $v $u + + foreach n [$G arcs -adj $v $u] { + struct::set exclude arcs $n + } + } + } + + return $vc +} + + +#Ford's Fulkerson algorithm - computing maximum flow in a flow network +#------------------------------------------------------------------------------------- +# +#The general idea of algorithm is finding augumenting paths in graph G, as long +#as they exist, and for each path updating the edge's weights along that path, +#with maximum possible throughput. The final (maximum) flow is found +#when there is no other augumenting path from source to sink. +# +#Input: +#graph G - weighted and directed graph. Weights at edges are considered as +#maximum throughputs that can be carried by that link (edge). +#s - the node that is a source for graph G +#t - the node that is a sink for graph G +# +#Output: +#Procedure returns the dictionary contaning throughputs for all edges. For +#each key ( the edge between nodes u and v in the for of list u v ) there is +#a value that is a throughput for that key. Edges where throughput values +#are equal to 0 are not returned ( it is like there was no link in the flow network +#between nodes connected by such edge). +# +#Reference: http://en.wikipedia.org/wiki/Ford-Fulkerson_algorithm + +proc ::struct::graph::op::FordFulkerson {G s t} { + + #checking if nodes s and t are in graph G + if { !([$G node exists $s] && [$G node exists $t]) } { + return -code error "Nodes \"$s\" and \"$t\" should be contained in graph's G set of nodes" + } + + #checking if all attributes for input network are set well ( costs and throughputs ) + foreach e [$G arcs] { + if { ![$G arc keyexists $e throughput] } { + return -code error "The input network doesn't have all attributes set correctly... Please, check again attributes: \"throughput\" for input graph." + } + } + + #initilization + foreach e [$G arcs] { + set u [$G arc source $e] + set v [$G arc target $e] + dict set f [list $u $v] 0 + dict set f [list $v $u] 0 + } + + #setting the residual graph for the first iteration + set residualG [createResidualGraph $G $f] + + #deleting the arcs that are 0-weighted + foreach e [$residualG arcs] { + if { [$residualG arc set $e throughput] == 0 } { + $residualG arc delete $e + } + } + + #the main loop - works till the path between source and the sink can be found + while {1} { + set paths [ShortestsPathsByBFS $residualG $s paths] + + if { ($paths == {}) || (![dict exists $paths $t]) } break + + set path [dict get $paths $t] + #setting the path from source to sink + + #adding sink to path + lappend path $t + + #finding the throughput of path p - the smallest value of c(f) among + #edges that are contained in the path + set maxThroughput Inf + + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + set pathEdgeFlow [$residualG arc set [list $u $v] throughput] + if { $maxThroughput > $pathEdgeFlow } { + set maxThroughput $pathEdgeFlow + } + } + + #increase of throughput using the path p, with value equal to maxThroughput + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + + #if maximum throughput that was found for the path p (maxThroughput) is bigger than current throughput + #at the edge not contained in the path p (for current pair of nodes u and v), then we add to the edge + #which is contained into path p the maxThroughput value decreased by the value of throughput at + #the second edge (not contained in path). That second edge's throughtput value is set to 0. + + set f_uv [dict get $f [list $u $v]] + set f_vu [dict get $f [list $v $u]] + if { $maxThroughput >= $f_vu } { + dict set f [list $u $v] [ expr { $f_uv + $maxThroughput - $f_vu } ] + dict set f [list $v $u] 0 + } else { + + #if maxThroughput is not greater than current throughput at the edge not contained in path p (here - v->u), + #we add a difference between those values to edge contained in the path p (here u->v) and substract that + #difference from edge not contained in the path p. + set difference [ expr { $f_vu - $maxThroughput } ] + dict set f [list $u $v] [ expr { $f_uv + $difference } ] + dict set f [list $v $u] $maxThroughput + } + } + + #when the current throughput for the graph is updated, we generate new residual graph + #for new values of throughput + $residualG destroy + set residualG [createResidualGraph $G $f] + + foreach e [$residualG arcs] { + if { [$residualG arc set $e throughput] == 0 } { + $residualG arc delete $e + } + } + } + + $residualG destroy + + #removing 0-weighted edges from solution + foreach e [dict keys $f] { + if { [dict get $f $e] == 0 } { + set f [dict remove $f $e] + } + } + + return $f +} + +#subprocedure for FordFulkerson's algorithm, which creates +#for input graph G and given throughput f residual graph +#for further operations to find maximum flow in flow network + +proc ::struct::graph::op::createResidualGraph {G f} { + + #initialization + set residualG [struct::graph] + + foreach v [$G nodes] { + $residualG node insert $v + } + + foreach e [$G arcs] { + set u [$G arc source $e] + set v [$G arc target $e] + dict set GF [list $u $v] [$G arc set $e throughput] + } + + foreach e [dict keys $GF] { + + lassign $e u v + + set c_uv [dict get $GF $e] + set flow_uv [dict get $f $e] + set flow_vu [dict get $f [list $v $u]] + + if { ![$residualG arc exists $e] } { + $residualG arc insert $u $v $e + } + + if { ![$residualG arc exists [list $v $u]] } { + $residualG arc insert $v $u [list $v $u] + } + + #new value of c_f(u,v) for residual Graph is a max flow value for this edge + #minus current flow on that edge + if { ![$residualG arc keyexists $e throughput] } { + if { [dict exists $GF [list $v $u]] } { + $residualG arc set [list $u $v] throughput [ expr { $c_uv - $flow_uv + $flow_vu } ] + } else { + $residualG arc set $e throughput [ expr { $c_uv - $flow_uv } ] + } + } + + if { [dict exists $GF [list $v $u]] } { + #when double arcs in graph G (u->v , v->u) + #so, x/y i w/z y-x+w + set c_vu [dict get $GF [list $v $u]] + if { ![$residualG arc keyexists [list $v $u] throughput] } { + $residualG arc set [list $v $u] throughput [ expr { $c_vu - $flow_vu + $flow_uv} ] + } + } else { + $residualG arc set [list $v $u] throughput $flow_uv + } + } + + #setting all weights at edges to 1 for proper usage of shortest paths finding procedures + $residualG arc setunweighted 1 + + return $residualG +} + +#Subprocedure for Busacker Gowen algorithm +# +#Input: +#graph G - flow network. Graph G has two attributes for each edge: +#cost and throughput. Each arc must have it's attribute value assigned. +#dictionary f - some flow for network G. Keys represent edges and values +#are flows at those edges +#path - set of nodes for which we transform the network +# +#Subprocedure checks 6 vital conditions and for them updates the network +#(let values with * be updates values for network). So, let edge (u,v) be +#the non-zero flow for network G, c(u,v) throughput of edge (u,v) and +#d(u,v) non-negative cost of edge (u,v): +#1. c*(v,u) = f(u,v) --- adding apparent arc +#2. d*(v,u) = -d(u,v) +#3. c*(u,v) = c(u,v) - f(u,v) --- if f(v,u) = 0 and c(u,v) > f(u,v) +#4. d*(u,v) = d(u,v) --- if f(v,u) = 0 and c(u,v) > f(u,v) +#5. c*(u,v) = 0 --- if f(v,u) = 0 and c(u,v) = f(u,v) +#6. d*(u,v) = Inf --- if f(v,u) = 0 and c(u,v) = f(u,v) + +proc ::struct::graph::op::createAugmentingNetwork {G f path} { + + set Gf [struct::graph] + + #setting the Gf graph + foreach v [$G nodes] { + $Gf node insert $v + } + + foreach e [$G arcs] { + set u [$G arc source $e] + set v [$G arc target $e] + + $Gf arc insert $u $v [list $u $v] + + $Gf arc set [list $u $v] throughput [$G arc set $e throughput] + $Gf arc set [list $u $v] cost [$G arc set $e cost] + } + + #we set new values for each edge contained in the path from input + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + + set f_uv [dict get $f [list $u $v]] + set f_vu [dict get $f [list $v $u]] + set c_uv [$G arc get [list $u $v] throughput] + set d_uv [$G arc get [list $u $v] cost] + + #adding apparent arcs + if { ![$Gf arc exists [list $v $u]] } { + $Gf arc insert $v $u [list $v $u] + #1. + $Gf arc set [list $v $u] throughput $f_uv + #2. + $Gf arc set [list $v $u] cost [ expr { -1 * $d_uv } ] + } else { + #1. + $Gf arc set [list $v $u] throughput $f_uv + #2. + $Gf arc set [list $v $u] cost [ expr { -1 * $d_uv } ] + $Gf arc set [list $u $v] cost Inf + $Gf arc set [list $u $v] throughput 0 + } + + if { ($f_vu == 0 ) && ( $c_uv > $f_uv ) } { + #3. + $Gf arc set [list $u $v] throughput [ expr { $c_uv - $f_uv } ] + #4. + $Gf arc set [list $u $v] cost $d_uv + } + + if { ($f_vu == 0 ) && ( $c_uv == $f_uv) } { + #5. + $Gf arc set [list $u $v] throughput 0 + #6. + $Gf arc set [list $u $v] cost Inf + } + } + + return $Gf +} + +#Busacker Gowen's algorithm - computing minimum cost maximum flow in a flow network +#------------------------------------------------------------------------------------- +# +#The goal is to find a flow, whose max value can be d, from source node to +#sink node in given flow network. That network except throughputs at edges has +#also defined a non-negative cost on each edge - cost of using that edge when +#directing flow with that edge ( it can illustrate e.g. fuel usage, time or +#any other measure dependent on usages ). +# +#Input: +#graph G - flow network, weights at edges are costs of using particular edge +#desiredFlow - max value of the flow for that network +#dictionary c - throughputs for all edges +#node s - the source node for graph G +#node t - the sink node for graph G +# +#Output: +#f - dictionary containing values of used throughputs for each edge ( key ) +#found by algorithm. +# +#Reference: http://en.wikipedia.org/wiki/Minimum_cost_flow_problem +# + +proc ::struct::graph::op::BusackerGowen {G desiredFlow s t} { + + #checking if nodes s and t are in graph G + if { !([$G node exists $s] && [$G node exists $t]) } { + return -code error "Nodes \"$s\" and \"$t\" should be contained in graph's G set of nodes" + } + + if { $desiredFlow <= 0 } { + return -code error "The \"desiredFlow\" value must be an positive integer." + } + + #checking if all attributes for input network are set well ( costs and throughputs ) + foreach e [$G arcs] { + if { !([$G arc keyexists $e throughput] && [$G arc keyexists $e cost]) } { + return -code error "The input network doesn't have all attributes set correctly... Please, check again attributes: \"throughput\" and \"cost\" for input graph." + } + } + + set Gf [struct::graph] + + #initialization of Augmenting Network + foreach v [$G nodes] { + $Gf node insert $v + } + + foreach e [$G arcs] { + set u [$G arc source $e] + set v [$G arc target $e] + $Gf arc insert $u $v [list $u $v] + + $Gf arc set [list $u $v] throughput [$G arc set $e throughput] + $Gf arc set [list $u $v] cost [$G arc set $e cost] + } + + #initialization of f + foreach e [$G arcs] { + set u [$G arc source $e] + set v [$G arc target $e] + dict set f [list $u $v] 0 + dict set f [list $v $u] 0 + } + + set currentFlow 0 + + #main loop - it ends when we reach desired flow value or there is no path in Gf + #leading from source node s to sink t + + while { $currentFlow < $desiredFlow } { + + #preparing correct values for pathfinding + foreach edge [$Gf arcs] { + $Gf arc setweight $edge [$Gf arc get $edge cost] + } + + #setting the path 'p' from 's' to 't' + set paths [ShortestsPathsByBFS $Gf $s paths] + + #if there are no more paths, the search has ended + if { ($paths == {}) || (![dict exists $paths $t]) } break + + set path [dict get $paths $t] + lappend path $t + + #counting max throughput that is availiable to send + #using path 'p' + set maxThroughput Inf + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + set uv_throughput [$Gf arc set [list $u $v] throughput] + if { $maxThroughput > $uv_throughput } { + set maxThroughput $uv_throughput + } + } + + #if max throughput that was found will cause exceeding the desired + #flow, send as much as it's possible + if { ( $currentFlow + $maxThroughput ) <= $desiredFlow } { + set fAdd $maxThroughput + set currentFlow [ expr { $currentFlow + $fAdd } ] + } else { + set fAdd [ expr { $desiredFlow - $currentFlow } ] + set currentFlow $desiredFlow + } + + #update the throuputs on edges + foreach v [lrange $path 0 end-1] u [lrange $path 1 end] { + if { [dict get $f [list $u $v]] >= $fAdd } { + dict set f [list $u $v] [ expr { [dict get $f [list $u $v]] - $fAdd } ] + } + + if { ( [dict get $f [list $u $v]] < $fAdd ) && ( [dict get $f [list $u $v]] > 0 ) } { + dict set f [list $v $u] [ expr { $fAdd - [dict get $f [list $u $v]] } ] + dict set f [list $u $v] 0 + } + + if { [dict get $f [list $u $v]] == 0 } { + dict set f [list $v $u] [ expr { [dict get $f [list $v $u]] + $fAdd } ] + } + } + + #create new Augemnting Network + + set Gfnew [createAugmentingNetwork $Gf $f $path] + $Gf destroy + set Gf $Gfnew + } + + set f [dict filter $f script {flow flowvalue} {expr {$flowvalue != 0}}] + + $Gf destroy + return $f +} + +# +proc ::struct::graph::op::ShortestsPathsByBFS {G s outputFormat} { + + switch -exact -- $outputFormat { + distances { + set outputMode distances + } + paths { + set outputMode paths + } + default { + return -code error "Unknown output format \"$outputFormat\", expected distances, or paths." + } + } + + set queue [list $s] + set result {} + + #initialization of marked nodes, distances and predecessors + foreach v [$G nodes] { + dict set marked $v 0 + dict set distances $v Inf + dict set pred $v -1 + } + + #the s node is initially marked and has 0 distance to itself + dict set marked $s 1 + dict set distances $s 0 + + #the main loop + while { [llength $queue] != 0 } { + + #removing top element from the queue + set v [lindex $queue 0] + lremove queue $v + + #for each arc that begins in v + foreach arc [$G arcs -out $v] { + + set u [$G arc target $arc] + set newlabel [ expr { [dict get $distances $v] + [$G arc getweight $arc] } ] + + if { $newlabel < [dict get $distances $u] } { + + dict set distances $u $newlabel + dict set pred $u $v + + #case when current node wasn't placed in a queue yet - + #we set u at the end of the queue + if { [dict get $marked $u] == 0 } { + lappend queue $u + dict set marked $u 1 + } else { + + #case when current node u was in queue before but it is not in it now - + #we set u at the beginning of the queue + if { [lsearch $queue $u] < 0 } { + set queue [linsert $queue 0 $u] + } + } + } + } + } + + #if the outputformat is paths, we travel back to find shorests paths + #to return sets of nodes for each node, which are their paths between + #s and particular node + dict set paths nopaths 1 + if { $outputMode eq "paths" } { + foreach node [$G nodes] { + + set path {} + set lastNode $node + + while { $lastNode != -1 } { + set currentNode [dict get $pred $lastNode] + if { $currentNode != -1 } { + lappend path $currentNode + } + set lastNode $currentNode + } + + set path [lreverse $path] + + if { [llength $path] != 0 } { + dict set paths $node $path + dict unset paths nopaths + } + } + + if { ![dict exists $paths nopaths] } { + return $paths + } else { + return {} + } + + #returning dictionary containing distance from start node to each other node (key) + } else { + return $distances + } + +} + +# +proc ::struct::graph::op::BFS {G s outputFormat} { + + set queue [list $s] + + switch -exact -- $outputFormat { + graph { + set outputMode graph + } + tree { + set outputMode tree + } + default { + return -code error "Unknown output format \"$outputFormat\", expected graph, or tree." + } + } + + if { $outputMode eq "graph" } { + #graph initializing + set BFSGraph [struct::graph] + foreach v [$G nodes] { + $BFSGraph node insert $v + } + } else { + #tree initializing + set BFSTree [struct::tree] + $BFSTree set root name $s + $BFSTree rename root $s + } + + #initilization of marked nodes + foreach v [$G nodes] { + dict set marked $v 0 + } + + #start node is marked from the beginning + dict set marked $s 1 + + #the main loop + while { [llength $queue] != 0 } { + #removing top element from the queue + + set v [lindex $queue 0] + lremove queue $v + + foreach x [$G nodes -adj $v] { + if { ![dict get $marked $x] } { + dict set marked $x 1 + lappend queue $x + + if { $outputMode eq "graph" } { + $BFSGraph arc insert $v $x [list $v $x] + } else { + $BFSTree insert $v end $x + } + } + } + } + + if { $outputMode eq "graph" } { + return $BFSGraph + } else { + return $BFSTree + } +} + +#Minimum Diameter Spanning Tree - MDST +#------------------------------------------------------------------------------------- +# +#The goal is to find for input graph G, the spanning tree that +#has the minimum diameter worth. +# +#General idea of algorithm is to run BFS over all vertices in graph +#G. If the diameter "d" of the tree is odd, then we are sure that tree +#given by BFS is minimum (considering diameter value). When, diameter "d" +#is even, then optimal tree can have minimum diameter equal to "d" or +#"d-1". +# +#In that case, what algorithm does is rebuilding the tree given by BFS, by +#adding a vertice between root node and root's child node (nodes), such that +#subtree created with child node as root node is the greatest one (has the +#greatests height). In the next step for such rebuilded tree, we run again BFS +#with new node as root node. If the height of the tree didn't changed, we have found +#a better solution. + +proc ::struct::graph::op::MinimumDiameterSpanningTree {G} { + + set min_diameter Inf + set best_Tree [struct::graph] + + foreach v [$G nodes] { + + #BFS Tree + set T [BFS $G $v tree] + #BFS Graph + set TGraph [BFS $G $v graph] + + #Setting all arcs to 1 for diameter procedure + $TGraph arc setunweighted 1 + + #setting values for current Tree + set diam [diameter $TGraph] + set subtreeHeight [ expr { $diam / 2 - 1} ] + + ############################################## + #case when diameter found for tree found by BFS is even: + #it's possible to decrease the diameter by one. + if { ( $diam % 2 ) == 0 } { + + #for each child u that current root node v has, we search + #for the greatest subtree(subtrees) with the root in child u. + # + foreach u [$TGraph nodes -adj $v] { + set u_depth 1 ;#[$T depth $u] + set d_depth 0 + + set descendants [$T descendants $u] + + foreach d $descendants { + if { $d_depth < [$T depth $d] } { + set d_depth [$T depth $d] + } + } + + #depth of the current subtree + set depth [ expr { $d_depth - $u_depth } ] + + #proceed if found subtree is the greatest one + if { $depth >= $subtreeHeight } { + + #temporary Graph for holding potential better values + set tempGraph [struct::graph] + + foreach node [$TGraph nodes] { + $tempGraph node insert $node + } + + #zmienic nazwy zmiennych zeby sie nie mylily + foreach arc [$TGraph arcs] { + set _u [$TGraph arc source $arc] + set _v [$TGraph arc target $arc] + $tempGraph arc insert $_u $_v [list $_u $_v] + } + + if { [$tempGraph arc exists [list $u $v]] } { + $tempGraph arc delete [list $u $v] + } else { + $tempGraph arc delete [list $v $u] + } + + #for nodes u and v, we add a node between them + #to again start BFS with root in new node to check + #if it's possible to decrease the diameter in solution + set node [$tempGraph node insert] + $tempGraph arc insert $node $v [list $node $v] + $tempGraph arc insert $node $u [list $node $u] + + set newtempGraph [BFS $tempGraph $node graph] + $tempGraph destroy + set tempGraph $newtempGraph + + $tempGraph node delete $node + $tempGraph arc insert $u $v [list $u $v] + $tempGraph arc setunweighted 1 + + set tempDiam [diameter $tempGraph] + + #if better tree is found (that any that were already found) + #replace it + if { $min_diameter > $tempDiam } { + set $min_diameter [diameter $tempGraph ] + $best_Tree destroy + set best_Tree $tempGraph + } else { + $tempGraph destroy + } + } + + } + } + ################################################################ + + set currentTreeDiameter $diam + + if { $min_diameter > $currentTreeDiameter } { + set min_diameter $currentTreeDiameter + $best_Tree destroy + set best_Tree $TGraph + } else { + $TGraph destroy + } + + $T destroy + } + + return $best_Tree +} + +#Minimum Degree Spanning Tree +#------------------------------------------------------------------------------------- +# +#In graph theory, minimum degree spanning tree (or degree-constrained spanning tree) +#is a spanning tree where the maximum vertex degree is as small as possible (or is +#limited to a certain constant k). The minimum degree spanning tree problem is to +#determine whether a particular graph has such a spanning tree for a particular k. +# +#Algorithm for input undirected graph G finds its spanning tree with the smallest +#possible degree. Algorithm is a 2-approximation, so it doesn't assure that optimal +#solution will be found. +# +#Reference: http://en.wikipedia.org/wiki/Degree-constrained_spanning_tree + +proc ::struct::graph::op::MinimumDegreeSpanningTree {G} { + + #initialization of spanning tree for G + set MST [struct::graph] + + foreach v [$G nodes] { + $MST node insert $v + } + + #forcing all arcs to be 1-weighted + foreach e [$G arcs] { + $G arc setweight $e 1 + } + + foreach e [kruskal $G] { + set u [$G arc source $e] + set v [$G arc target $e] + + $MST arc insert $u $v [list $u $v] + } + + #main loop + foreach e [$G arcs] { + + set u [$G arc source $e] + set v [$G arc target $e] + + #if nodes u and v are neighbours, proceed to next iteration + if { ![$MST arc exists [list $u $v]] && ![$MST arc exists [list $v $u]] } { + + $MST arc setunweighted 1 + + #setting the path between nodes u and v in Spanning Tree MST + set path [dict get [dijkstra $MST $u] $v] + lappend path $v + + #search for the node in the path, such that its degree is greater than degree of any of nodes + #u or v increased by one + foreach node $path { + if { [$MST node degree $node] > ([Max [$MST node degree $u] [$MST node degree $v]] + 1) } { + + #if such node is found add the arc between nodes u and v + $MST arc insert $u $v [list $u $v] + + #then to hold MST being a spanning tree, delete any arc that is in the path + #that is adjacent to found node + foreach n [$MST nodes -adj $node] { + if { $n in $path } { + if { [$MST arc exists [list $node $n]] } { + $MST arc delete [list $node $n] + } else { + $MST arc delete [list $n $node] + } + break + } + } + + # Node found, stop processing the path + break + } + } + } + } + + return $MST +} + +#Dinic algorithm for finding maximum flow in flow network +#------------------------------------------------------------------------------------- +# +#Reference: http://en.wikipedia.org/wiki/Dinic's_algorithm +# +proc ::struct::graph::op::MaximumFlowByDinic {G s t blockingFlowAlg} { + + if { !($blockingFlowAlg eq "dinic" || $blockingFlowAlg eq "mkm") } { + return -code error "Uncorrect name of blocking flow algorithm. Choose \"mkm\" for Malhotra, Kumar and Maheshwari algorithm and \"dinic\" for Dinic algorithm." + } + + foreach arc [$G arcs] { + set u [$G arc source $arc] + set v [$G arc target $arc] + + dict set f [list $u $v] 0 + dict set f [list $v $u] 0 + } + + while {1} { + set residualG [createResidualGraph $G $f] + if { $blockingFlowAlg == "mkm" } { + set blockingFlow [BlockingFlowByMKM $residualG $s $t] + } else { + set blockingFlow [BlockingFlowByDinic $residualG $s $t] + } + $residualG destroy + + if { $blockingFlow == {} } break + + foreach key [dict keys $blockingFlow] { + dict set f $key [ expr { [dict get $f $key] + [dict get $blockingFlow $key] } ] + } + } + + set f [dict filter $f script {flow flowvalue} {expr {$flowvalue != 0}}] + + return $f +} + +#Dinic algorithm for finding blocking flow +#------------------------------------------------------------------------------------- +# +#Algorithm for given network G with source s and sink t, finds a blocking +#flow, which can be used to obtain a maximum flow for that network G. +# +#Some steps that algorithm takes: +#1. constructing the level graph from network G +#2. until there are edges in level graph: +# 3. find the path between s and t nodes in level graph +# 4. for each edge in path update current throughputs at those edges and... +# 5. ...deleting nodes from which there are no residual edges +#6. return the dictionary containing the blocking flow + +proc ::struct::graph::op::BlockingFlowByDinic {G s t} { + + #initializing blocking flow dictionary + foreach edge [$G arcs] { + set u [$G arc source $edge] + set v [$G arc target $edge] + + dict set b [list $u $v] 0 + } + + #1. + set LevelGraph [createLevelGraph $G $s] + + #2. the main loop + while { [llength [$LevelGraph arcs]] > 0 } { + + if { ![$LevelGraph node exists $s] || ![$LevelGraph node exists $t] } break + + #3. + set paths [ShortestsPathsByBFS $LevelGraph $s paths] + + if { $paths == {} } break + if { ![dict exists $paths $t] } break + + set path [dict get $paths $t] + lappend path $t + + #setting the max throughput to go with the path found one step before + set maxThroughput Inf + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + + set uv_throughput [$LevelGraph arc get [list $u $v] throughput] + + if { $maxThroughput > $uv_throughput } { + set maxThroughput $uv_throughput + } + } + + #4. updating throughputs and blocking flow + foreach u [lrange $path 0 end-1] v [lrange $path 1 end] { + + set uv_throughput [$LevelGraph arc get [list $u $v] throughput] + #decreasing the throughputs contained in the path by max flow value + $LevelGraph arc set [list $u $v] throughput [ expr { $uv_throughput - $maxThroughput } ] + + #updating blocking flows + dict set b [list $u $v] [ expr { [dict get $b [list $u $v]] + $maxThroughput } ] + #dict set b [list $v $u] [ expr { -1 * [dict get $b [list $u $v]] } ] + + #5. deleting the arcs, whose throughput is completely used + if { [$LevelGraph arc get [list $u $v] throughput] == 0 } { + $LevelGraph arc delete [list $u $v] + } + + #deleting the node, if it hasn't any outgoing arcs + if { ($u != $s) && ( ![llength [$LevelGraph nodes -out $u]] || ![llength [$LevelGraph nodes -in $u]] ) } { + $LevelGraph node delete $u + } + } + + } + + set b [dict filter $b script {flow flowvalue} {expr {$flowvalue != 0}}] + + $LevelGraph destroy + + #6. + return $b +} + +#Malhotra, Kumar and Maheshwari Algorithm for finding blocking flow +#------------------------------------------------------------------------------------- +# +#Algorithm for given network G with source s and sink t, finds a blocking +#flow, which can be used to obtain a maximum flow for that network G. +# +#For given node v, Let c(v) be the min{ a, b }, where a is the sum of all incoming +#throughputs and b is the sum of all outcoming throughputs from the node v. +# +#Some steps that algorithm takes: +#1. constructing the level graph from network G +#2. until there are edges in level graph: +# 3. finding the node with the minimum c(v) +# 4. sending c(v) units of throughput by incoming arcs of v +# 5. sending c(v) units of throughput by outcoming arcs of v +# 6. 4 and 5 steps can cause excess or deficiency of throughputs at nodes, so we +# send exceeds forward choosing arcs greedily and... +# 7. ...the same with deficiencies but we send those backward. +# 8. delete the v node from level graph +# 9. upgrade the c values for all nodes +# +#10. if no other edges left in level graph, return b - found blocking flow +# + +proc ::struct::graph::op::BlockingFlowByMKM {G s t} { + + #initializing blocking flow dictionary + foreach edge [$G arcs] { + set u [$G arc source $edge] + set v [$G arc target $edge] + + dict set b [list $u $v] 0 + } + + #1. setting the level graph + set LevelGraph [createLevelGraph $G $s] + + #setting the in/out throughputs for each node + set c [countThroughputsAtNodes $LevelGraph $s $t] + + #2. the main loop + while { [llength [$LevelGraph nodes]] > 2 } { + + #if there is no path between s and t nodes, end the procedure and + #return current blocking flow + set distances [ShortestsPathsByBFS $LevelGraph $s distances] + if { [dict get $distances $t] == "Inf" } { + $LevelGraph destroy + set b [dict filter $b script {flow flowvalue} {expr {$flowvalue != 0}}] + return $b + } + + #3. finding the node with minimum value of c(v) + set min_cv Inf + + dict for {node cv} $c { + if { $min_cv > $cv } { + set min_cv $cv + set minCv_node $node + } + } + + #4. sending c(v) by all incoming arcs of node with minimum c(v) + set _min_cv $min_cv + foreach arc [$LevelGraph arcs -in $minCv_node] { + + set t_arc [$LevelGraph arc get $arc throughput] + set u [$LevelGraph arc source $arc] + set v [$LevelGraph arc target $arc] + set b_uv [dict get $b [list $u $v]] + + if { $t_arc >= $min_cv } { + $LevelGraph arc set $arc throughput [ expr { $t_arc - $min_cv } ] + dict set b [list $u $v] [ expr { $b_uv + $min_cv } ] + break + } else { + set difference [ expr { $min_cv - $t_arc } ] + set min_cv $difference + dict set b [list $u $v] [ expr { $b_uv + $difference } ] + $LevelGraph arc set $arc throughput 0 + } + } + + #5. sending c(v) by all outcoming arcs of node with minimum c(v) + foreach arc [$LevelGraph arcs -out $minCv_node] { + + set t_arc [$LevelGraph arc get $arc throughput] + set u [$LevelGraph arc source $arc] + set v [$LevelGraph arc target $arc] + set b_uv [dict get $b [list $u $v]] + + if { $t_arc >= $min_cv } { + $LevelGraph arc set $arc throughput [ expr { $t_arc - $_min_cv } ] + dict set b [list $u $v] [ expr { $b_uv + $_min_cv } ] + break + } else { + set difference [ expr { $_min_cv - $t_arc } ] + set _min_cv $difference + dict set b [list $u $v] [ expr { $b_uv + $difference } ] + $LevelGraph arc set $arc throughput 0 + } + } + + #find exceeds and if any, send them forward or backwards + set distances [ShortestsPathsByBFS $LevelGraph $s distances] + + #6. + for {set i [ expr {[dict get $distances $minCv_node] + 1}] } { $i < [llength [$G nodes]] } { incr i } { + foreach w [$LevelGraph nodes] { + if { [dict get $distances $w] == $i } { + set excess [findExcess $LevelGraph $w $b] + if { $excess > 0 } { + set b [sendForward $LevelGraph $w $b $excess] + } + } + } + } + + #7. + for { set i [ expr { [dict get $distances $minCv_node] - 1} ] } { $i > 0 } { incr i -1 } { + foreach w [$LevelGraph nodes] { + if { [dict get $distances $w] == $i } { + set excess [findExcess $LevelGraph $w $b] + if { $excess < 0 } { + set b [sendBack $LevelGraph $w $b [ expr { (-1) * $excess } ]] + } + } + } + } + + #8. delete current node from the network + $LevelGraph node delete $minCv_node + + #9. correctingg the in/out throughputs for each node after + #deleting one of the nodes in network + set c [countThroughputsAtNodes $LevelGraph $s $t] + + #if node has no availiable outcoming or incoming throughput + #delete that node from the graph + dict for {key val} $c { + if { $val == 0 } { + $LevelGraph node delete $key + dict unset c $key + } + } + } + + set b [dict filter $b script {flow flowvalue} {expr {$flowvalue != 0}}] + + $LevelGraph destroy + #10. + return $b +} + +#Subprocedure for algorithms that find blocking-flows. +#It's creating a level graph from the residual network. +proc ::struct::graph::op::createLevelGraph {Gf s} { + + set LevelGraph [struct::graph] + + $Gf arc setunweighted 1 + + #deleting arcs with 0 throughputs for proper pathfinding + foreach arc [$Gf arcs] { + if { [$Gf arc get $arc throughput] == 0 } { + $Gf arc delete $arc + } + } + + set distances [ShortestsPathsByBFS $Gf $s distances] + + foreach v [$Gf nodes] { + $LevelGraph node insert $v + $LevelGraph node set $v distance [dict get $distances $v] + } + + foreach e [$Gf arcs] { + set u [$Gf arc source $e] + set v [$Gf arc target $e] + + if { ([$LevelGraph node get $u distance] + 1) == [$LevelGraph node get $v distance]} { + $LevelGraph arc insert $u $v [list $u $v] + $LevelGraph arc set [list $u $v] throughput [$Gf arc get $e throughput] + } + } + + $LevelGraph arc setunweighted 1 + return $LevelGraph +} + +#Subprocedure for blocking flow finding by MKM algorithm +# +#It computes for graph G and each of his nodes the throughput value - +#for node v: from the sum of availiable throughputs from incoming arcs and +#the sum of availiable throughputs from outcoming arcs chooses lesser and sets +#as the throughput of the node. +# +#Throughputs of nodes are returned in the dictionary. +# +proc ::struct::graph::op::countThroughputsAtNodes {G s t} { + + set c {} + foreach v [$G nodes] { + + if { ($v eq $t) || ($v eq $s) } continue + + set outcoming [$G arcs -out $v] + set incoming [$G arcs -in $v] + + set outsum 0 + set insum 0 + + foreach o $outcoming i $incoming { + + if { [llength $o] > 0 } { + set outsum [ expr { $outsum + [$G arc get $o throughput] } ] + } + + if { [llength $i] > 0 } { + set insum [ expr { $insum + [$G arc get $i throughput] } ] + } + + set value [Min $outsum $insum] + } + + dict set c $v $value + } + + return $c +} + +#Subprocedure for blocking-flow finding algorithm by MKM +# +#If for a given input node, outcoming flow is bigger than incoming, then that deficiency +#has to be send back by that subprocedure. +proc ::struct::graph::op::sendBack {G node b value} { + + foreach arc [$G arcs -in $node] { + set u [$G arc source $arc] + set v [$G arc target $arc] + + if { $value > [$G arc get $arc throughput] } { + set value [ expr { $value - [$G arc get $arc throughput] } ] + dict set b [list $u $v] [ expr { [dict get $b [list $u $v]] + [$G arc get $arc throughput] } ] + $G arc set $arc throughput 0 + } else { + $G arc set $arc throughput [ expr { [$G arc get $arc throughput] - $value } ] + dict set b [list $u $v] [ expr { [dict get $b [list $u $v]] + $value } ] + set value 0 + break + } + } + + return $b +} + +#Subprocedure for blocking-flow finding algorithm by MKM +# +#If for a given input node, incoming flow is bigger than outcoming, then that exceed +#has to be send forward by that sub procedure. +proc ::struct::graph::op::sendForward {G node b value} { + + foreach arc [$G arcs -out $node] { + + set u [$G arc source $arc] + set v [$G arc target $arc] + + if { $value > [$G arc get $arc throughput] } { + set value [ expr { $value - [$G arc get $arc throughput] } ] + dict set b [list $u $v] [ expr { [dict get $b [list $u $v]] + [$G arc get $arc throughput] } ] + $G arc set $arc throughput 0 + } else { + $G arc set $arc throughput [ expr { [$G arc get $arc throughput] - $value } ] + dict set b [list $u $v] [ expr { [dict get $b [list $u $v]] + $value } ] + + set value 0 + break + } + } + + return $b +} + +#Subprocedure for blocking-flow finding algorithm by MKM +# +#It checks for graph G if node given at input has a exceed +#or deficiency of throughput. +# +#For exceed the positive value of exceed is returned, for deficiency +#procedure returns negative value. If the incoming throughput +#is the same as outcoming, procedure returns 0. +# +proc ::struct::graph::op::findExcess {G node b} { + + set incoming 0 + set outcoming 0 + + foreach key [dict keys $b] { + + lassign $key u v + if { $u eq $node } { + set outcoming [ expr { $outcoming + [dict get $b $key] } ] + } + if { $v eq $node } { + set incoming [ expr { $incoming + [dict get $b $key] } ] + } + } + + return [ expr { $incoming - $outcoming } ] +} + +#Travelling Salesman Problem - Heuristic of local searching +#2 - approximation Algorithm +#------------------------------------------------------------------------------------- +# + +proc ::struct::graph::op::TSPLocalSearching {G C} { + + foreach arc $C { + if { ![$G arc exists $arc] } { + return -code error "Given cycle has arcs not included in graph G." + } + } + + #initialization + set CGraph [struct::graph] + set GCopy [struct::graph] + set w 0 + + foreach node [$G nodes] { + $CGraph node insert $node + $GCopy node insert $node + } + + foreach arc [$G arcs] { + set u [$G arc source $arc] + set v [$G arc target $arc] + $GCopy arc insert $u $v [list $u $v] + $GCopy arc set [list $u $v] weight [$G arc get $arc weight] + } + + foreach arc $C { + + set u [$G arc source $arc] + set v [$G arc target $arc] + set arcWeight [$G arc get $arc weight] + + $CGraph arc insert $u $v [list $u $v] + $CGraph arc set [list $u $v] weight $arcWeight + + set w [ expr { $w + $arcWeight } ] + } + + set reductionDone 1 + + while { $reductionDone } { + + set queue {} + set reductionDone 0 + + #double foreach loop goes through all pairs of arcs + foreach i [$CGraph arcs] { + + #source and target nodes of first arc + set iu [$CGraph arc source $i] + set iv [$CGraph arc target $i] + + #second arc + foreach j [$CGraph arcs] { + + #if pair of arcs already was considered, continue with next pair of arcs + if { [list $j $i] ni $queue } { + + #add current arc to queue to mark that it was used + lappend queue [list $i $j] + + set ju [$CGraph arc source $j] + set jv [$CGraph arc target $j] + + #we consider only arcs that are not adjacent + if { !($iu eq $ju) && !($iu eq $jv) && !($iv eq $ju) && !($iv eq $jv) } { + + #set the current cycle + set CPrim [copyGraph $CGraph] + + #transform the current cycle: + #1. + $CPrim arc delete $i + $CPrim arc delete $j + + + set param 0 + + #adding new edges instead of erased ones + if { !([$CPrim arc exists [list $iu $ju]] || [$CPrim arc exists [list $iv $jv]] || [$CPrim arc exists [list $ju $iu]] || [$CPrim arc exists [list $jv $iv]] ) } { + + $CPrim arc insert $iu $ju [list $iu $ju] + $CPrim arc insert $iv $jv [list $iv $jv] + + if { [$GCopy arc exists [list $iu $ju]] } { + $CPrim arc set [list $iu $ju] weight [$GCopy arc get [list $iu $ju] weight] + } else { + $CPrim arc set [list $iu $ju] weight [$GCopy arc get [list $ju $iu] weight] + } + + if { [$GCopy arc exists [list $iv $jv]] } { + $CPrim arc set [list $iv $jv] weight [$GCopy arc get [list $iv $jv] weight] + } else { + $CPrim arc set [list $iv $jv] weight [$GCopy arc get [list $jv $iv] weight] + } + } else { + set param 1 + } + + $CPrim arc setunweighted 1 + + #check if it's still a cycle or if any arcs were added instead those erased + if { !([struct::graph::op::distance $CPrim $iu $ju] > 0 ) || $param } { + + #deleting new edges if they were added before in current iteration + if { !$param } { + $CPrim arc delete [list $iu $ju] + } + + if { !$param } { + $CPrim arc delete [list $iv $jv] + } + + #adding new ones that will assure the graph is still a cycle + $CPrim arc insert $iu $jv [list $iu $jv] + $CPrim arc insert $iv $ju [list $iv $ju] + + if { [$GCopy arc exists [list $iu $jv]] } { + $CPrim arc set [list $iu $jv] weight [$GCopy arc get [list $iu $jv] weight] + } else { + $CPrim arc set [list $iu $jv] weight [$GCopy arc get [list $jv $iu] weight] + } + + if { [$GCopy arc exists [list $iv $ju]] } { + $CPrim arc set [list $iv $ju] weight [$GCopy arc get [list $iv $ju] weight] + } else { + $CPrim arc set [list $iv $ju] weight [$GCopy arc get [list $ju $iv] weight] + } + } + + #count current value of cycle + set cycleWeight [countCycleWeight $CPrim] + + #if we found cycle with lesser sum of weights, we set is as a result and + #marked that reduction was successful + if { $w > $cycleWeight } { + set w $cycleWeight + set reductionDone 1 + set C [$CPrim arcs] + } + + $CPrim destroy + } + } + } + } + + #setting the new current cycle if the reduction was successful + if { $reductionDone } { + foreach arc [$CGraph arcs] { + $CGraph arc delete $arc + } + for {set i 0} { $i < [llength $C] } { incr i } { + lset C $i [lsort [lindex $C $i]] + } + + foreach arc [$GCopy arcs] { + if { [lsort $arc] in $C } { + set u [$GCopy arc source $arc] + set v [$GCopy arc target $arc] + $CGraph arc insert $u $v [list $u $v] + $CGraph arc set $arc weight [$GCopy arc get $arc weight] + } + } + } + } + + $GCopy destroy + $CGraph destroy + + return $C +} + +proc ::struct::graph::op::copyGraph {G} { + + set newGraph [struct::graph] + + foreach node [$G nodes] { + $newGraph node insert $node + } + foreach arc [$G arcs] { + set u [$G arc source $arc] + set v [$G arc target $arc] + $newGraph arc insert $u $v $arc + $newGraph arc set $arc weight [$G arc get $arc weight] + } + + return $newGraph +} + +proc ::struct::graph::op::countCycleWeight {G} { + + set result 0 + + foreach arc [$G arcs] { + set result [ expr { $result + [$G arc get $arc weight] } ] + } + + return $result +} + +# ### ### ### ######### ######### ######### +## + +# This command finds a minimum spanning tree/forest (MST) of the graph +# argument, using the algorithm developed by Joseph Kruskal. The +# result is a set (as list) containing the names of the arcs in the +# MST. The set of nodes of the MST is implied by set of arcs, and thus +# not given explicitly. The algorithm does not consider arc +# directions. Note that unconnected nodes are left out of the result. + +# Reference: http://en.wikipedia.org/wiki/Kruskal%27s_algorithm + +proc ::struct::graph::op::kruskal {g} { + # Check graph argument for proper configuration. + + VerifyWeightsAreOk $g + + # Transient helper data structures. A priority queue for the arcs + # under consideration, using their weights as priority, and a + # disjoint-set to keep track of the forest of partial minimum + # spanning trees we are working with. + + set consider [::struct::prioqueue -dictionary consider] + set forest [::struct::disjointset forest] + + # Start with all nodes in the graph each in their partition. + + foreach n [$g nodes] { + $forest add-partition $n + } + + # Then fill the queue with all arcs, using their weight to + # prioritize. The weight is the cost of the arc. The lesser the + # better. + + foreach {arc weight} [$g arc weights] { + $consider put $arc $weight + } + + # And now we can construct the tree. This is done greedily. In + # each round we add the arc with the smallest weight to the + # minimum spanning tree, except if doing so would violate the tree + # condition. + + set result {} + + while {[$consider size]} { + set minarc [$consider get] + set origin [$g arc source $minarc] + set destin [$g arc target $minarc] + + # Ignore the arc if both ends are in the same partition. Using + # it would add a cycle to the result, i.e. it would not be a + # tree anymore. + + if {[$forest equal $origin $destin]} continue + + # Take the arc for the result, and merge the trees both ends + # are in into a single tree. + + lappend result $minarc + $forest merge $origin $destin + } + + # We are done. Get rid of the transient helper structures and + # return our result. + + $forest destroy + $consider destroy + + return $result +} + +# ### ### ### ######### ######### ######### +## + +# This command finds a minimum spanning tree/forest (MST) of the graph +# argument, using the algorithm developed by Prim. The result is a +# set (as list) containing the names of the arcs in the MST. The set +# of nodes of the MST is implied by set of arcs, and thus not given +# explicitly. The algorithm does not consider arc directions. + +# Reference: http://en.wikipedia.org/wiki/Prim%27s_algorithm + +proc ::struct::graph::op::prim {g} { + VerifyWeightsAreOk $g + + # Fill an array with all nodes, to track which nodes have been + # visited at least once. When the inner loop runs out of nodes and + # we still have some left over we restart using one of the + # leftover as new starting point. In this manner we get the MST of + # the whole graph minus unconnected nodes, instead of only the MST + # for the component the initial starting node is in. + + array set unvisited {} + foreach n [$g nodes] { set unvisited($n) . } + + # Transient helper data structure. A priority queue for the nodes + # and arcs under consideration for inclusion into the MST. Each + # element of the queue is a list containing node name, a flag bit, + # and arc name, in this order. The associated priority is the + # weight of the arc. The flag bit is set for the initial queue + # entry only, containing a fake (empty) arc, to trigger special + # handling. + + set consider [::struct::prioqueue -dictionary consider] + + # More data structures, the result arrays. + array set weightmap {} ; # maps nodes to min arc weight seen so + # far. This is the threshold other arcs + # on this node will have to beat to be + # added to the MST. + array set arcmap {} ; # maps arcs to nothing, these are the + # arcs in the MST. + + while {[array size unvisited]} { + # Choose a 'random' node as the starting point for the inner + # loop, prim's algorithm, and put it on the queue for + # consideration. Then we iterate until we have considered all + # nodes in the its component. + + set startnode [lindex [array names unvisited] 0] + $consider put [list $startnode 1 {}] 0 + + while {[$consider size] > 0} { + # Pull the next minimum weight to look for. This is the + # priority of the next item we can get from the queue. And the + # associated node/decision/arc data. + + set arcweight [$consider peekpriority 1] + + foreach {v arcundefined arc} [$consider get] break + #8.5: lassign [$consider get] v arcundefined arc + + # Two cases to consider: The node v is already part of the + # MST, or not. If yes we check if the new arcweight is better + # than what we have stored already, and update accordingly. + + if {[info exists weightmap($v)]} { + set currentweight $weightmap($v) + if {$arcweight < $currentweight} { + # The new weight is better, update to use it as + # the new threshold. Note that this fill not touch + # any other arcs found for this node, as these are + # still minimal. + + set weightmap($v) $arcweight + set arcmap($arc) . + } + } else { + # Node not yet present. Save weight and arc. The + # latter if and only the arc is actually defined. For + # the first, initial queue entry, it is not. Then we + # add all the arcs adjacent to the current node to the + # queue to consider them in the next rounds. + + set weightmap($v) $arcweight + if {!$arcundefined} { + set arcmap($arc) . + } + foreach adjacentarc [$g arcs -adj $v] { + set weight [$g arc getweight $adjacentarc] + set neighbour [$g node opposite $v $adjacentarc] + $consider put [list $neighbour 0 $adjacentarc] $weight + } + } + + # Mark the node as visited, belonging to the current + # component. Future iterations will ignore it. + unset -nocomplain unvisited($v) + } + } + + # We are done. Get rid of the transient helper structure and + # return our result. + + $consider destroy + + return [array names arcmap] +} + +# ### ### ### ######### ######### ######### +## + +# This command checks whether the graph argument is bi-partite or not, +# and returns the result as a boolean value, true for a bi-partite +# graph, and false otherwise. A variable can be provided to store the +# bi-partition into. +# +# Reference: http://en.wikipedia.org/wiki/Bipartite_graph + +proc ::struct::graph::op::isBipartite? {g {bipartitionvar {}}} { + + # Handle the special cases of empty graphs, or one without arcs + # quickly. Both are bi-partite. + + if {$bipartitionvar ne ""} { + upvar 1 $bipartitionvar bipartitions + } + if {![llength [$g nodes]]} { + set bipartitions {{} {}} + return 1 + } elseif {![llength [$g arcs]]} { + if {$bipartitionvar ne ""} { + set bipartitions [list [$g nodes] {}] + } + return 1 + } + + # Transient helper data structure, a queue of the nodes waiting + # for processing. + + set pending [struct::queue pending] + set nodes [$g nodes] + + # Another structure, a map from node names to their 'color', + # indicating which of the two partitions a node belngs to. All + # nodes start out as undefined (0). Traversing the arcs we + # set and flip them as needed (1,2). + + array set color {} + foreach node $nodes { + set color($node) 0 + } + + # Iterating over all nodes we use their connections to traverse + # the components and assign colors. We abort when encountering + # paradox, as that means that the graph is not bi-partite. + + foreach node $nodes { + # Ignore nodes already in the second partition. + if {$color($node)} continue + + # Flip the color, then travel the component and check for + # conflicts with the neighbours. + + set color($node) 1 + + $pending put $node + while {[$pending size]} { + set current [$pending get] + foreach neighbour [$g nodes -adj $current] { + if {!$color($neighbour)} { + # Exchange the color between current and previous + # nodes, and remember the neighbour for further + # processing. + set color($neighbour) [expr {3 - $color($current)}] + $pending put $neighbour + } elseif {$color($neighbour) == $color($current)} { + # Color conflict between adjacent nodes, should be + # different. This graph is not bi-partite. Kill + # the data structure and abort. + + $pending destroy + return 0 + } + } + } + } + + # The graph is bi-partite. Kill the transient data structure, and + # move the partitions into the provided variable, if there is any. + + $pending destroy + + if {$bipartitionvar ne ""} { + # Build bipartition, then set the data into the variable + # passed as argument to this command. + + set X {} + set Y {} + + foreach {node partition} [array get color] { + if {$partition == 1} { + lappend X $node + } else { + lappend Y $node + } + } + set bipartitions [list $X $Y] + } + + return 1 +} + +# ### ### ### ######### ######### ######### +## + +# This command computes a maximal matching, if it exists, for the +# graph argument G and its bi-partition as specified through the node +# sets X and Y. As is implied, this method requires that the graph is +# bi-partite. Use the command 'isBipartite?' to check for this +# property, and to obtain the bi-partition. +if 0 { + proc ::struct::graph::op::maxMatching {g X Y} { + return -code error "not implemented yet" + }} + +# ### ### ### ######### ######### ######### +## + +# This command computes the strongly connected components (SCCs) of +# the graph argument G. The result is a list of node-sets, each set +# containing the nodes of one SCC of G. In any SCC there is a directed +# path between any two nodes U, V from U to V. If all SCCs contain +# only a single node the graph is acyclic. + +proc ::struct::graph::op::tarjan {g} { + set all [$g nodes] + + # Quick bailout for simple special cases, i.e. graphs without + # nodes or arcs. + if {![llength $all]} { + # No nodes => no SCCs + return {} + } elseif {![llength [$g arcs]]} { + # Have nodes, but no arcs => each node is its own SCC. + set r {} ; foreach a $all { lappend r [list $a] } + return $r + } + + # Transient data structures. Stack of nodes to consider, the + # result, and various state arrays. TarjanSub upvar's all them + # into its scope. + + set pending [::struct::stack pending] + set result {} + + array set index {} + array set lowlink {} + array set instack {} + + # Invoke the main search system while we have unvisited + # nodes. TarjanSub will remove all visited nodes from 'all', + # ensuring termination. + + while {[llength $all]} { + TarjanSub [lindex $all 0] 0 + } + + # Release the transient structures and return result. + $pending destroy + return $result +} + +proc ::struct::graph::op::TarjanSub {start counter} { + # Import the tracer state from our caller. + upvar 1 g g index index lowlink lowlink instack instack result result pending pending all all + + struct::set subtract all $start + + set component {} + set index($start) $counter + set lowlink($start) $counter + incr counter + + $pending push $start + set instack($start) 1 + + foreach outarc [$g arcs -out $start] { + set neighbour [$g arc target $outarc] + + if {![info exists index($neighbour)]} { + # depth-first-search of reachable nodes from the neighbour + # node. Original from the chosen startnode. + TarjanSub $neighbour $counter + set lowlink($start) [Min $lowlink($start) $lowlink($neighbour)] + + } elseif {[info exists instack($neighbour)]} { + set lowlink($start) [Min $lowlink($start) $lowlink($neighbour)] + } + } + + # Check if the 'start' node on this recursion level is the root + # node of a SCC, and collect the component if yes. + + if {$lowlink($start) == $index($start)} { + while {1} { + set v [$pending pop] + unset instack($v) + lappend component $v + if {$v eq $start} break + } + lappend result $component + } + + return +} + +# ### ### ### ######### ######### ######### +## + +# This command computes the connected components (CCs) of the graph +# argument G. The result is a list of node-sets, each set containing +# the nodes of one CC of G. In any CC there is UN-directed path +# between any two nodes U, V. + +proc ::struct::graph::op::connectedComponents {g} { + set all [$g nodes] + + # Quick bailout for simple special cases, i.e. graphs without + # nodes or arcs. + if {![llength $all]} { + # No nodes => no CCs + return {} + } elseif {![llength [$g arcs]]} { + # Have nodes, but no arcs => each node is its own CC. + set r {} ; foreach a $all { lappend r [list $a] } + return $r + } + + # Invoke the main search system while we have unvisited + # nodes. + + set result {} + while {[llength $all]} { + set component [ComponentOf $g [lindex $all 0]] + lappend result $component + # all = all - component + struct::set subtract all $component + } + return $result +} + +# A derivative command which computes the connected component (CC) of +# the graph argument G containing the node N. The result is a node-set +# containing the nodes of the CC of N in G. + +proc ::struct::graph::op::connectedComponentOf {g n} { + # Quick bailout for simple special cases + if {![$g node exists $n]} { + return -code error "node \"$n\" does not exist in graph \"$g\"" + } elseif {![llength [$g arcs -adj $n]]} { + # The chosen node has no neighbours, so is its own CC. + return [list $n] + } + + # Invoke the main search system for the chosen node. + + return [ComponentOf $g $n] +} + +# Internal helper for finding connected components. + +proc ::struct::graph::op::ComponentOf {g start} { + set pending [::struct::queue pending] + $pending put $start + + array set visited {} + set visited($start) . + + while {[$pending size]} { + set current [$pending get 1] + foreach neighbour [$g nodes -adj $current] { + if {[info exists visited($neighbour)]} continue + $pending put $neighbour + set visited($neighbour) 1 + } + } + $pending destroy + return [array names visited] +} + +# ### ### ### ######### ######### ######### +## + +# This command determines if the specified arc A in the graph G is a +# bridge, i.e. if its removal will split the connected component its +# end nodes belong to, into two. The result is a boolean value. Uses +# the 'ComponentOf' helper command. + +proc ::struct::graph::op::isBridge? {g arc} { + if {![$g arc exists $arc]} { + return -code error "arc \"$arc\" does not exist in graph \"$g\"" + } + + # Note: We could avoid the need for a copy of the graph if we were + # willing to modify G (*). As we are not willing using a copy is + # the easiest way to allow us a trivial modification. For the + # future consider the creation of a graph class which represents + # virtual graphs over a source, generated by deleting nodes and/or + # arcs. without actually modifying the source. + # + # (Ad *): Create a new unnamed helper node X. Move the arc + # destination to X. Recompute the component and ignore + # X. Then move the arc target back to its original node + # and remove X again. + + set src [$g arc source $arc] + set compBefore [ComponentOf $g $src] + if {[llength $compBefore] == 1} { + # Special case, the arc is a loop on an otherwise unconnected + # node. The component will not split, this is not a bridge. + return 0 + } + + set copy [struct::graph BridgeCopy = $g] + $copy arc delete $arc + set compAfter [ComponentOf $copy $src] + $copy destroy + + return [expr {[llength $compBefore] != [llength $compAfter]}] +} + +# This command determines if the specified node N in the graph G is a +# cut vertex, i.e. if its removal will split the connected component +# it belongs to into two. The result is a boolean value. Uses the +# 'ComponentOf' helper command. + +proc ::struct::graph::op::isCutVertex? {g n} { + if {![$g node exists $n]} { + return -code error "node \"$n\" does not exist in graph \"$g\"" + } + + # Note: We could avoid the need for a copy of the graph if we were + # willing to modify G (*). As we are not willing using a copy is + # the easiest way to allow us a trivial modification. For the + # future consider the creation of a graph class which represents + # virtual graphs over a source, generated by deleting nodes and/or + # arcs. without actually modifying the source. + # + # (Ad *): Create two new unnamed helper nodes X and Y. Move the + # icoming and outgoing arcs to these helpers. Recompute + # the component and ignore the helpers. Then move the arcs + # back to their original nodes and remove the helpers + # again. + + set compBefore [ComponentOf $g $n] + + if {[llength $compBefore] == 1} { + # Special case. The node is unconnected. Its removal will + # cause no changes. Therefore not a cutvertex. + return 0 + } + + # We remove the node from the original component, so that we can + # select a new start node without fear of hitting on the + # cut-vertex candidate. Also makes the comparison later easier + # (straight ==). + struct::set subtract compBefore $n + + set copy [struct::graph CutVertexCopy = $g] + $copy node delete $n + set compAfter [ComponentOf $copy [lindex $compBefore 0]] + $copy destroy + + return [expr {[llength $compBefore] != [llength $compAfter]}] +} + +# This command determines if the graph G is connected. + +proc ::struct::graph::op::isConnected? {g} { + return [expr { [llength [connectedComponents $g]] == 1 }] +} + +# ### ### ### ######### ######### ######### +## + +# This command determines if the specified graph G has an eulerian +# cycle (aka euler tour, <=> g is eulerian) or not. If yes, it can +# return the cycle through the named variable, as a list of arcs +# traversed. +# +# Note that for a graph to be eulerian all nodes have to have an even +# degree, and the graph has to be connected. And if more than two +# nodes have an odd degree the graph is not even semi-eulerian (cannot +# even have an euler path). + +proc ::struct::graph::op::isEulerian? {g {eulervar {}} {tourstart {}}} { + set nodes [$g nodes] + if {![llength $nodes] || ![llength [$g arcs]]} { + # Quick bailout for special cases. No nodes, or no arcs imply + # that no euler cycle is present. + return 0 + } + + # Check the condition regarding even degree nodes, then + # connected-ness. + + foreach n $nodes { + if {([$g node degree $n] % 2) == 0} continue + # Odd degree node found, not eulerian. + return 0 + } + + if {![isConnected? $g]} { + return 0 + } + + # At this point the graph is connected, with all nodes of even + # degree. As per Carl Hierholzer the graph has to have an euler + # tour. If the user doesn't request it we do not waste the time to + # actually compute one. + + if {$tourstart ne ""} { + upvar 1 $tourstart start + } + + # We start the tour at an arbitrary node. + set start [lindex $nodes 0] + + if {$eulervar eq ""} { + return 1 + } + + upvar 1 $eulervar tour + Fleury $g $start tour + return 1 +} + +# This command determines if the specified graph G has an eulerian +# path (<=> g is semi-eulerian) or not. If yes, it can return the +# path through the named variable, as a list of arcs traversed. +# +# (*) Aka euler tour. +# +# Note that for a graph to be semi-eulerian at most two nodes are +# allowed to have an odd degree, all others have to be of even degree, +# and the graph has to be connected. + +proc ::struct::graph::op::isSemiEulerian? {g {eulervar {}}} { + set nodes [$g nodes] + if {![llength $nodes] || ![llength [$g arcs]]} { + # Quick bailout for special cases. No nodes, or no arcs imply + # that no euler path is present. + return 0 + } + + # Check the condition regarding oddd/even degree nodes, then + # connected-ness. + + set odd 0 + foreach n $nodes { + if {([$g node degree $n] % 2) == 0} continue + incr odd + set lastodd $n + } + if {($odd > 2) || ![isConnected? $g]} { + return 0 + } + + # At this point the graph is connected, with the node degrees + # supporting existence of an euler path. If the user doesn't + # request it we do not waste the time to actually compute one. + + if {$eulervar eq ""} { + return 1 + } + + upvar 1 $eulervar path + + # We start at either an odd-degree node, or any node, if there are + # no odd-degree ones. In the last case we are actually + # constructing an euler tour, i.e. a closed path. + + if {$odd} { + set start $lastodd + } else { + set start [lindex $nodes 0] + } + + Fleury $g $start path + return 1 +} + +proc ::struct::graph::op::Fleury {g start eulervar} { + upvar 1 $eulervar path + + # We start at the chosen node. + + set copy [struct::graph FleuryCopy = $g] + set path {} + + # Edges are chosen per Fleury's algorithm. That is easy, + # especially as we already have a command to determine whether an + # arc is a bridge or not. + + set arcs [$copy arcs] + while {![struct::set empty $arcs]} { + set adjacent [$copy arcs -adj $start] + + if {[llength $adjacent] == 1} { + # No choice in what arc to traverse. + set arc [lindex $adjacent 0] + } else { + # Choose first non-bridge arcs. The euler conditions force + # that at least two such are present. + + set has 0 + foreach arc $adjacent { + if {[isBridge? $copy $arc]} { + continue + } + set has 1 + break + } + if {!$has} { + $copy destroy + return -code error {Internal error} + } + } + + set start [$copy node opposite $start $arc] + $copy arc delete $arc + struct::set exclude arcs $arc + lappend path $arc + } + + $copy destroy + return +} + +# ### ### ### ######### ######### ######### +## + +# This command uses dijkstra's algorithm to find all shortest paths in +# the graph G starting at node N. The operation can be configured to +# traverse arcs directed and undirected, and the format of the result. + +proc ::struct::graph::op::dijkstra {g node args} { + # Default traversal is undirected. + # Default output format is tree. + + set arcTraversal undirected + set resultFormat tree + + # Process options to override the defaults, if any. + foreach {option param} $args { + switch -exact -- $option { + -arcmode { + switch -exact -- $param { + directed - + undirected { + set arcTraversal $param + } + default { + return -code error "Bad value for -arcmode, expected one of \"directed\" or \"undirected\"" + } + } + } + -outputformat { + switch -exact -- $param { + tree - + distances { + set resultFormat $param + } + default { + return -code error "Bad value for -outputformat, expected one of \"distances\" or \"tree\"" + } + } + } + default { + return -code error "Bad option \"$option\", expected one of \"-arcmode\" or \"-outputformat\"" + } + } + } + + # We expect that all arcs of g are given a weight. + VerifyWeightsAreOk $g + + # And the start node has to belong to the graph too, of course. + if {![$g node exists $node]} { + return -code error "node \"$node\" does not exist in graph \"$g\"" + } + + # TODO: Quick bailout for special cases (no arcs). + + # Transient and other data structures for the core algorithm. + set pending [::struct::prioqueue -dictionary DijkstraQueue] + array set distance {} ; # array: node -> distance to 'n' + array set previous {} ; # array: node -> parent in shortest path to 'n'. + array set visited {} ; # array: node -> bool, true when node processed + + # Initialize the data structures. + foreach n [$g nodes] { + set distance($n) Inf + set previous($n) undefined + set visited($n) 0 + } + + # Compute the distances ... + $pending put $node 0 + set distance($node) 0 + set previous($node) none + + while {[$pending size]} { + set current [$pending get] + set visited($current) 1 + + # Traversal to neighbours according to the chosen mode. + if {$arcTraversal eq "undirected"} { + set arcNeighbours [$g arcs -adj $current] + } else { + set arcNeighbours [$g arcs -out $current] + } + + # Compute distances, record newly discovered nodes, minimize + # distances for nodes reachable through multiple paths. + foreach arcNeighbour $arcNeighbours { + set cost [$g arc getweight $arcNeighbour] + set neighbour [$g node opposite $current $arcNeighbour] + set delta [expr {$distance($current) + $cost}] + + if { + ($distance($neighbour) eq "Inf") || + ($delta < $distance($neighbour)) + } { + # First path, or better path to the node folund, + # update our records. + + set distance($neighbour) $delta + set previous($neighbour) $current + if {!$visited($neighbour)} { + $pending put $neighbour $delta + } + } + } + } + + $pending destroy + + # Now generate the result based on the chosen format. + if {$resultFormat eq "distances"} { + return [array get distance] + } else { + array set listofprevious {} + foreach n [$g nodes] { + set current $n + while {1} { + if {$current eq "undefined"} break + if {$current eq $node} { + lappend listofprevious($n) $current + break + } + if {$current ne $n} { + lappend listofprevious($n) $current + } + set current $previous($current) + } + } + return [array get listofprevious] + } +} + +# This convenience command is a wrapper around dijkstra's algorithm to +# find the (un)directed distance between two nodes in the graph G. + +proc ::struct::graph::op::distance {g origin destination args} { + if {![$g node exists $origin]} { + return -code error "node \"$origin\" does not exist in graph \"$g\"" + } + if {![$g node exists $destination]} { + return -code error "node \"$destination\" does not exist in graph \"$g\"" + } + + set arcTraversal undirected + + # Process options to override the defaults, if any. + foreach {option param} $args { + switch -exact -- $option { + -arcmode { + switch -exact -- $param { + directed - + undirected { + set arcTraversal $param + } + default { + return -code error "Bad value for -arcmode, expected one of \"directed\" or \"undirected\"" + } + } + } + default { + return -code error "Bad option \"$option\", expected \"-arcmode\"" + } + } + } + + # Quick bailout for special case: the distance from a node to + # itself is zero + + if {$origin eq $destination} { + return 0 + } + + # Compute all distances, then pick and return the one we are + # interested in. + array set distance [dijkstra $g $origin -outputformat distances -arcmode $arcTraversal] + return $distance($destination) +} + +# This convenience command is a wrapper around dijkstra's algorithm to +# find the (un)directed eccentricity of the node N in the graph G. The +# eccentricity is the maximal distance to any other node in the graph. + +proc ::struct::graph::op::eccentricity {g node args} { + if {![$g node exists $node]} { + return -code error "node \"$node\" does not exist in graph \"$g\"" + } + + set arcTraversal undirected + + # Process options to override the defaults, if any. + foreach {option param} $args { + switch -exact -- $option { + -arcmode { + switch -exact -- $param { + directed - + undirected { + set arcTraversal $param + } + default { + return -code error "Bad value for -arcmode, expected one of \"directed\" or \"undirected\"" + } + } + } + default { + return -code error "Bad option \"$option\", expected \"-arcmode\"" + } + } + } + + # Compute all distances, then pick out the max + + set ecc 0 + foreach {n distance} [dijkstra $g $node -outputformat distances -arcmode $arcTraversal] { + if {$distance eq "Inf"} { return Inf } + if {$distance > $ecc} { set ecc $distance } + } + + return $ecc +} + +# This convenience command is a wrapper around eccentricity to find +# the (un)directed radius of the graph G. The radius is the minimal +# eccentricity over all nodes in the graph. + +proc ::struct::graph::op::radius {g args} { + return [lindex [RD $g $args] 0] +} + +# This convenience command is a wrapper around eccentricity to find +# the (un)directed diameter of the graph G. The diameter is the +# maximal eccentricity over all nodes in the graph. + +proc ::struct::graph::op::diameter {g args} { + return [lindex [RD $g $args] 1] +} + +proc ::struct::graph::op::RD {g options} { + set arcTraversal undirected + + # Process options to override the defaults, if any. + foreach {option param} $options { + switch -exact -- $option { + -arcmode { + switch -exact -- $param { + directed - + undirected { + set arcTraversal $param + } + default { + return -code error "Bad value for -arcmode, expected one of \"directed\" or \"undirected\"" + } + } + } + default { + return -code error "Bad option \"$option\", expected \"-arcmode\"" + } + } + } + + set radius Inf + set diameter 0 + foreach n [$g nodes] { + set e [eccentricity $g $n -arcmode $arcTraversal] + #puts "$n ==> ($e)" + if {($e eq "Inf") || ($e > $diameter)} { + set diameter $e + } + if {($radius eq "Inf") || ($e < $radius)} { + set radius $e + } + } + + return [list $radius $diameter] +} + +# +## place holder for operations to come +# + +# ### ### ### ######### ######### ######### +## Internal helpers + +proc ::struct::graph::op::Min {first second} { + if {$first > $second} { + return $second + } else { + return $first + } +} + +proc ::struct::graph::op::Max {first second} { + if {$first < $second} { + return $second + } else { + return $first + } +} + +# This method verifies that every arc on the graph has a weight +# assigned to it. This is required for some algorithms. +proc ::struct::graph::op::VerifyWeightsAreOk {g} { + if {![llength [$g arc getunweighted]]} return + return -code error "Operation invalid for graph with unweighted arcs." +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct::graph::op { + #namespace export ... +} + +package provide struct::graph::op 0.11.4 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/list.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/list.tcl new file mode 100644 index 00000000..d20fa92e --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/list.tcl @@ -0,0 +1,1834 @@ +#---------------------------------------------------------------------- +# +# list.tcl -- +# +# Definitions for extended processing of Tcl lists. +# +# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: list.tcl,v 1.27 2011/09/17 14:35:36 mic42 Exp $ +# +#---------------------------------------------------------------------- + +package require Tcl 8.5 9 +package require cmdline + +namespace eval ::struct { namespace eval list {} } + +namespace eval ::struct::list { + namespace export list + + if {0} { + # Possibly in the future. + namespace export Lassign + namespace export LdbJoin + namespace export LdbJoinOuter + namespace export Ldelete + namespace export Lequal + namespace export Lfilter + namespace export Lfilterfor + namespace export Lfirstperm + namespace export Lflatten + namespace export Lfold + namespace export Lforeachperm + namespace export Liota + namespace export LlcsInvert + namespace export LlcsInvert2 + namespace export LlcsInvertMerge + namespace export LlcsInvertMerge2 + namespace export LlongestCommonSubsequence + namespace export LlongestCommonSubsequence2 + namespace export Lmap + namespace export Lmapfor + namespace export Lnextperm + namespace export Lpermutations + namespace export Lrepeat + namespace export Lrepeatn + namespace export Lreverse + namespace export Lshift + namespace export Lswap + namespace export Lshuffle + } +} + +########################## +# Public functions + +# ::struct::list::list -- +# +# Command that access all list commands. +# +# Arguments: +# cmd Name of the subcommand to dispatch to. +# args Arguments for the subcommand. +# +# Results: +# Whatever the result of the subcommand is. + +proc ::struct::list::list {cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 1 } { + return -code error "wrong # args: should be \"$cmd ?arg arg ...?\"" + } + set sub L$cmd + if { [llength [info commands ::struct::list::$sub]] == 0 } { + set optlist [info commands ::struct::list::L*] + set xlist {} + foreach p $optlist { + lappend xlist [string range $p 1 end] + } + return -code error \ + "bad option \"$cmd\": must be [linsert [join $xlist ", "] "end-1" "or"]" + } + return [uplevel 1 [linsert $args 0 ::struct::list::$sub]] +} + +########################## +# Private functions follow + +proc ::struct::list::K { x y } { set x } + +########################## +# Implementations of the functionality. +# + +# ::struct::list::LlongestCommonSubsequence -- +# +# Computes the longest common subsequence of two lists. +# +# Parameters: +# sequence1, sequence2 -- Two lists to compare. +# maxOccurs -- If provided, causes the procedure to ignore +# lines that appear more than $maxOccurs times +# in the second sequence. See below for a discussion. +# Results: +# Returns a list of two lists of equal length. +# The first sublist is of indices into sequence1, and the +# second sublist is of indices into sequence2. Each corresponding +# pair of indices corresponds to equal elements in the sequences; +# the sequence returned is the longest possible. +# +# Side effects: +# None. +# +# Notes: +# +# While this procedure is quite rapid for many tasks of file +# comparison, its performance degrades severely if the second list +# contains many equal elements (as, for instance, when using this +# procedure to compare two files, a quarter of whose lines are blank. +# This drawback is intrinsic to the algorithm used (see the References +# for details). One approach to dealing with this problem that is +# sometimes effective in practice is arbitrarily to exclude elements +# that appear more than a certain number of times. This number is +# provided as the 'maxOccurs' parameter. If frequent lines are +# excluded in this manner, they will not appear in the common subsequence +# that is computed; the result will be the longest common subsequence +# of infrequent elements. +# +# The procedure struct::list::LongestCommonSubsequence2 +# functions as a wrapper around this procedure; it computes the longest +# common subsequence of infrequent elements, and then subdivides the +# subsequences that lie between the matches to approximate the true +# longest common subsequence. +# +# References: +# J. W. Hunt and M. D. McIlroy, "An algorithm for differential +# file comparison," Comp. Sci. Tech. Rep. #41, Bell Telephone +# Laboratories (1976). Available on the Web at the second +# author's personal site: http://www.cs.dartmouth.edu/~doug/ + +proc ::struct::list::LlongestCommonSubsequence { + sequence1 + sequence2 + {maxOccurs 0x7fffffff} +} { + # Construct a set of equivalence classes of lines in file 2 + + set index 0 + foreach string $sequence2 { + lappend eqv($string) $index + incr index + } + + # K holds descriptions of the common subsequences. + # Initially, there is one common subsequence of length 0, + # with a fence saying that it includes line -1 of both files. + # The maximum subsequence length is 0; position 0 of + # K holds a fence carrying the line following the end + # of both files. + + lappend K [::list -1 -1 {}] + lappend K [::list [llength $sequence1] [llength $sequence2] {}] + set k 0 + + # Walk through the first file, letting i be the index of the line and + # string be the line itself. + + set i 0 + foreach string $sequence1 { + # Consider each possible corresponding index j in the second file. + + if { [info exists eqv($string)] + && [llength $eqv($string)] <= $maxOccurs } { + + # c is the candidate match most recently found, and r is the + # length of the corresponding subsequence. + + set r 0 + set c [lindex $K 0] + + foreach j $eqv($string) { + # Perform a binary search to find a candidate common + # subsequence to which may be appended this match. + + set max $k + set min $r + set s [expr { $k + 1 }] + while { $max >= $min } { + set mid [expr { ( $max + $min ) / 2 }] + set bmid [lindex [lindex $K $mid] 1] + if { $j == $bmid } { + break + } elseif { $j < $bmid } { + set max [expr {$mid - 1}] + } else { + set s $mid + set min [expr { $mid + 1 }] + } + } + + # Go to the next match point if there is no suitable + # candidate. + + if { $j == [lindex [lindex $K $mid] 1] || $s > $k} { + continue + } + + # s is the sequence length of the longest sequence + # to which this match point may be appended. Make + # a new candidate match and store the old one in K + # Set r to the length of the new candidate match. + + set newc [::list $i $j [lindex $K $s]] + if { $r >= 0 } { + lset K $r $c + } + set c $newc + set r [expr { $s + 1 }] + + # If we've extended the length of the longest match, + # we're done; move the fence. + + if { $s >= $k } { + lappend K [lindex $K end] + incr k + break + } + } + + # Put the last candidate into the array + + lset K $r $c + } + + incr i + } + + # Package the common subsequence in a convenient form + + set seta {} + set setb {} + set q [lindex $K $k] + + for { set i 0 } { $i < $k } {incr i } { + lappend seta {} + lappend setb {} + } + while { [lindex $q 0] >= 0 } { + incr k -1 + lset seta $k [lindex $q 0] + lset setb $k [lindex $q 1] + set q [lindex $q 2] + } + + return [::list $seta $setb] +} + +# ::struct::list::LlongestCommonSubsequence2 -- +# +# Derives an approximation to the longest common subsequence +# of two lists. +# +# Parameters: +# sequence1, sequence2 - Lists to be compared +# maxOccurs - Parameter for imprecise matching - see below. +# +# Results: +# Returns a list of two lists of equal length. +# The first sublist is of indices into sequence1, and the +# second sublist is of indices into sequence2. Each corresponding +# pair of indices corresponds to equal elements in the sequences; +# the sequence returned is an approximation to the longest possible. +# +# Side effects: +# None. +# +# Notes: +# This procedure acts as a wrapper around the companion procedure +# struct::list::LongestCommonSubsequence and accepts the same +# parameters. It first computes the longest common subsequence of +# elements that occur no more than $maxOccurs times in the +# second list. Using that subsequence to align the two lists, +# it then tries to augment the subsequence by computing the true +# longest common subsequences of the sublists between matched pairs. + +proc ::struct::list::LlongestCommonSubsequence2 { + sequence1 + sequence2 + {maxOccurs 0x7fffffff} +} { + # Derive the longest common subsequence of elements that occur at + # most $maxOccurs times + + foreach { l1 l2 } \ + [LlongestCommonSubsequence $sequence1 $sequence2 $maxOccurs] { + break + } + + # Walk through the match points in the sequence just derived. + + set result1 {} + set result2 {} + set n1 0 + set n2 0 + foreach i1 $l1 i2 $l2 { + if { $i1 != $n1 && $i2 != $n2 } { + # The match points indicate that there are unmatched + # elements lying between them in both input sequences. + # Extract the unmatched elements and perform precise + # longest-common-subsequence analysis on them. + + set subl1 [lrange $sequence1 $n1 [expr { $i1 - 1 }]] + set subl2 [lrange $sequence2 $n2 [expr { $i2 - 1 }]] + foreach { m1 m2 } [LlongestCommonSubsequence $subl1 $subl2] break + foreach j1 $m1 j2 $m2 { + lappend result1 [expr { $j1 + $n1 }] + lappend result2 [expr { $j2 + $n2 }] + } + } + + # Add the current match point to the result + + lappend result1 $i1 + lappend result2 $i2 + set n1 [expr { $i1 + 1 }] + set n2 [expr { $i2 + 1 }] + } + + # If there are unmatched elements after the last match in both files, + # perform precise longest-common-subsequence matching on them and + # add the result to our return. + + if { $n1 < [llength $sequence1] && $n2 < [llength $sequence2] } { + set subl1 [lrange $sequence1 $n1 end] + set subl2 [lrange $sequence2 $n2 end] + foreach { m1 m2 } [LlongestCommonSubsequence $subl1 $subl2] break + foreach j1 $m1 j2 $m2 { + lappend result1 [expr { $j1 + $n1 }] + lappend result2 [expr { $j2 + $n2 }] + } + } + + return [::list $result1 $result2] +} + +# ::struct::list::LlcsInvert -- +# +# Takes the data describing a longest common subsequence of two +# lists and inverts the information in the sense that the result +# of this command will describe the differences between the two +# sequences instead of the identical parts. +# +# Parameters: +# lcsData longest common subsequence of two lists as +# returned by longestCommonSubsequence(2). +# Results: +# Returns a single list whose elements describe the differences +# between the original two sequences. Each element describes +# one difference through three pieces, the type of the change, +# a pair of indices in the first sequence and a pair of indices +# into the second sequence, in this order. +# +# Side effects: +# None. + +proc ::struct::list::LlcsInvert {lcsData len1 len2} { + return [LlcsInvert2 [::lindex $lcsData 0] [::lindex $lcsData 1] $len1 $len2] +} + +proc ::struct::list::LlcsInvert2 {idx1 idx2 len1 len2} { + set result {} + set last1 -1 + set last2 -1 + + foreach a $idx1 b $idx2 { + # Four possible cases. + # a) last1 ... a and last2 ... b are not empty. + # This is a 'change'. + # b) last1 ... a is empty, last2 ... b is not. + # This is an 'addition'. + # c) last1 ... a is not empty, last2 ... b is empty. + # This is a deletion. + # d) If both ranges are empty we can ignore the + # two current indices. + + set empty1 [expr {($a - $last1) <= 1}] + set empty2 [expr {($b - $last2) <= 1}] + + if {$empty1 && $empty2} { + # Case (d), ignore the indices + } elseif {$empty1} { + # Case (b), 'addition'. + incr last2 ; incr b -1 + lappend result [::list added [::list $last1 $a] [::list $last2 $b]] + incr b + } elseif {$empty2} { + # Case (c), 'deletion' + incr last1 ; incr a -1 + lappend result [::list deleted [::list $last1 $a] [::list $last2 $b]] + incr a + } else { + # Case (q), 'change'. + incr last1 ; incr a -1 + incr last2 ; incr b -1 + lappend result [::list changed [::list $last1 $a] [::list $last2 $b]] + incr a + incr b + } + + set last1 $a + set last2 $b + } + + # Handle the last chunk, using the information about the length of + # the original sequences. + + set empty1 [expr {($len1 - $last1) <= 1}] + set empty2 [expr {($len2 - $last2) <= 1}] + + if {$empty1 && $empty2} { + # Case (d), ignore the indices + } elseif {$empty1} { + # Case (b), 'addition'. + incr last2 ; incr len2 -1 + lappend result [::list added [::list $last1 $len1] [::list $last2 $len2]] + } elseif {$empty2} { + # Case (c), 'deletion' + incr last1 ; incr len1 -1 + lappend result [::list deleted [::list $last1 $len1] [::list $last2 $len2]] + } else { + # Case (q), 'change'. + incr last1 ; incr len1 -1 + incr last2 ; incr len2 -1 + lappend result [::list changed [::list $last1 $len1] [::list $last2 $len2]] + } + + return $result +} + +proc ::struct::list::LlcsInvertMerge {lcsData len1 len2} { + return [LlcsInvertMerge2 [::lindex $lcsData 0] [::lindex $lcsData 1] $len1 $len2] +} + +proc ::struct::list::LlcsInvertMerge2 {idx1 idx2 len1 len2} { + set result {} + set last1 -1 + set last2 -1 + + foreach a $idx1 b $idx2 { + # Four possible cases. + # a) last1 ... a and last2 ... b are not empty. + # This is a 'change'. + # b) last1 ... a is empty, last2 ... b is not. + # This is an 'addition'. + # c) last1 ... a is not empty, last2 ... b is empty. + # This is a deletion. + # d) If both ranges are empty we can ignore the + # two current indices. For merging we simply + # take the information from the input. + + set empty1 [expr {($a - $last1) <= 1}] + set empty2 [expr {($b - $last2) <= 1}] + + if {$empty1 && $empty2} { + # Case (d), add 'unchanged' chunk. + set type -- + foreach {type left right} [lindex $result end] break + if {[string match unchanged $type]} { + # There is an existing result to extend + lset left end $a + lset right end $b + lset result end [::list unchanged $left $right] + } else { + # There is an unchanged result at the start of the list; + # it may be extended. + lappend result [::list unchanged [::list $a $a] [::list $b $b]] + } + } else { + if {$empty1} { + # Case (b), 'addition'. + incr last2 ; incr b -1 + lappend result [::list added [::list $last1 $a] [::list $last2 $b]] + incr b + } elseif {$empty2} { + # Case (c), 'deletion' + incr last1 ; incr a -1 + lappend result [::list deleted [::list $last1 $a] [::list $last2 $b]] + incr a + } else { + # Case (a), 'change'. + incr last1 ; incr a -1 + incr last2 ; incr b -1 + lappend result [::list changed [::list $last1 $a] [::list $last2 $b]] + incr a + incr b + } + # Finally, the two matching lines are a new unchanged region + lappend result [::list unchanged [::list $a $a] [::list $b $b]] + } + set last1 $a + set last2 $b + } + + # Handle the last chunk, using the information about the length of + # the original sequences. + + set empty1 [expr {($len1 - $last1) <= 1}] + set empty2 [expr {($len2 - $last2) <= 1}] + + if {$empty1 && $empty2} { + # Case (d), ignore the indices + } elseif {$empty1} { + # Case (b), 'addition'. + incr last2 ; incr len2 -1 + lappend result [::list added [::list $last1 $len1] [::list $last2 $len2]] + } elseif {$empty2} { + # Case (c), 'deletion' + incr last1 ; incr len1 -1 + lappend result [::list deleted [::list $last1 $len1] [::list $last2 $len2]] + } else { + # Case (q), 'change'. + incr last1 ; incr len1 -1 + incr last2 ; incr len2 -1 + lappend result [::list changed [::list $last1 $len1] [::list $last2 $len2]] + } + + return $result +} + +# ::struct::list::Lreverse -- +# +# Reverses the contents of the list and returns the reversed +# list as the result of the command. +# +# Parameters: +# sequence List to be reversed. +# +# Results: +# The sequence in reverse. +# +# Side effects: +# None. + +proc ::struct::list::Lreverse {sequence} { + set l [::llength $sequence] + + # Shortcut for lists where reversing yields the list itself + if {$l < 2} {return $sequence} + + # Perform true reversal + set res [::list] + while {$l} { + ::lappend res [::lindex $sequence [incr l -1]] + } + return $res +} + + +# ::struct::list::Lassign -- +# +# Assign list elements to variables. +# +# Parameters: +# sequence List to assign +# args Names of the variables to assign to. +# +# Results: +# The unassigned part of the sequence. Can be empty. +# +# Side effects: +# None. + +# Do a compatibility version of [assign] for pre-8.5 versions of Tcl. + +if { [package vcompare [package provide Tcl] 8.5] < 0 } { + # 8.4 + proc ::struct::list::Lassign {sequence v args} { + set args [linsert $args 0 $v] + set a [::llength $args] + + # Nothing to assign. + #if {$a == 0} {return $sequence} + + # Perform assignments + set i 0 + foreach v $args { + upvar 1 $v var + set var [::lindex $sequence $i] + incr i + } + + # Return remainder, if there is any. + return [::lrange $sequence $a end] +} + +} else { + # For 8.5+ simply redirect the method to the core command. + + interp alias {} ::struct::list::Lassign {} lassign +} + + +# ::struct::list::Lshift -- +# +# Shift a list in a variable one element down, and return first element +# +# Parameters: +# listvar Name of variable containing the list to shift. +# +# Results: +# The first element of the list. +# +# Side effects: +# After the call the list variable will contain +# the second to last elements of the list. + +proc ::struct::list::Lshift {listvar} { + upvar 1 $listvar list + set list [Lassign [K $list [set list {}]] v] + return $v +} + + +# ::struct::list::Lflatten -- +# +# Remove nesting from the input +# +# Parameters: +# sequence List to flatten +# +# Results: +# The input list with one or all levels of nesting removed. +# +# Side effects: +# None. + +proc ::struct::list::Lflatten {args} { + if {[::llength $args] < 1} { + return -code error \ + "wrong#args: should be \"::struct::list::Lflatten ?-full? ?--? sequence\"" + } + + set full 0 + while {[string match -* [set opt [::lindex $args 0]]]} { + switch -glob -- $opt { + -full {set full 1} + -- { + set args [::lrange $args 1 end] + break ; # fix ticket 6e778502b8 -- break exits while loop + } + default { + return -code error "Unknown option \"$opt\", should be either -full, or --" + } + } + set args [::lrange $args 1 end] + } + + if {[::llength $args] != 1} { + return -code error \ + "wrong#args: should be \"::struct::list::Lflatten ?-full? ?--? sequence\"" + } + + set sequence [::lindex $args 0] + set cont 1 + while {$cont} { + set cont 0 + set result [::list] + foreach item $sequence { + # catch/llength detects if the item is following the list + # syntax. + + if {[catch {llength $item} len]} { + # Element is not a list in itself, no flatten, add it + # as is. + lappend result $item + } else { + # Element is parseable as list, add all sub-elements + # to the result. + foreach e $item { + lappend result $e + } + } + } + if {$full && [string compare $sequence $result]} {set cont 1} + set sequence $result + } + return $result +} + + +# ::struct::list::Lmap -- +# +# Apply command to each element of a list and return concatenated results. +# +# Parameters: +# sequence List to operate on +# cmdprefix Operation to perform on the elements. +# +# Results: +# List containing the result of applying cmdprefix to the elements of the +# sequence. +# +# Side effects: +# None of its own, but the command prefix can perform arbitry actions. + +proc ::struct::list::Lmap {sequence cmdprefix} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $sequence} + + set res [::list] + foreach item $sequence { + lappend res [uplevel 1 [linsert $cmdprefix end $item]] + } + return $res +} + +# ::struct::list::Lmapfor -- +# +# Apply a script to each element of a list and return concatenated results. +# +# Parameters: +# sequence List to operate on +# script The script to run on the elements. +# +# Results: +# List containing the result of running script on the elements of the +# sequence. +# +# Side effects: +# None of its own, but the script can perform arbitry actions. + +proc ::struct::list::Lmapfor {var sequence script} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $sequence} + upvar 1 $var item + + set res [::list] + foreach item $sequence { + lappend res [uplevel 1 $script] + } + return $res +} + +# ::struct::list::Lfilter -- +# +# Apply command to each element of a list and return elements passing the test. +# +# Parameters: +# sequence List to operate on +# cmdprefix Test to perform on the elements. +# +# Results: +# List containing the elements of the input passing the test command. +# +# Side effects: +# None of its own, but the command prefix can perform arbitrary actions. + +proc ::struct::list::Lfilter {sequence cmdprefix} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $sequence} + return [uplevel 1 [::list ::struct::list::Lfold $sequence {} [::list ::struct::list::FTest $cmdprefix]]] +} + +proc ::struct::list::FTest {cmdprefix result item} { + set pass [uplevel 1 [::linsert $cmdprefix end $item]] + if {$pass} {::lappend result $item} + return $result +} + +# ::struct::list::Lfilterfor -- +# +# Apply expr condition to each element of a list and return elements passing the test. +# +# Parameters: +# sequence List to operate on +# expr Test to perform on the elements. +# +# Results: +# List containing the elements of the input passing the test expression. +# +# Side effects: +# None of its own, but the command prefix can perform arbitrary actions. + +proc ::struct::list::Lfilterfor {var sequence expr} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $sequence} + + upvar 1 $var item + set result {} + foreach item $sequence { + if {[uplevel 1 [::list ::expr $expr]]} { + lappend result $item + } + } + return $result +} + +# ::struct::list::Lsplit -- +# +# Apply command to each element of a list and return elements passing +# and failing the test. Basic idea by Salvatore Sanfilippo +# (http://wiki.tcl.tk/lsplit). The implementation here is mine (AK), +# and the interface is slightly different (Command prefix with the +# list element given to it as argument vs. variable + script). +# +# Parameters: +# sequence List to operate on +# cmdprefix Test to perform on the elements. +# args = empty | (varPass varFail) +# +# Results: +# If the variables are specified then a list containing the +# numbers of passing and failing elements, in this +# order. Otherwise a list having two elements, the lists of +# passing and failing elements, in this order. +# +# Side effects: +# None of its own, but the command prefix can perform arbitrary actions. + +proc ::struct::list::Lsplit {sequence cmdprefix args} { + set largs [::llength $args] + if {$largs == 0} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return {{} {}}} + return [uplevel 1 [::list [namespace which Lfold] $sequence {} [ + ::list ::struct::list::PFTest $cmdprefix]]] + } elseif {$largs == 2} { + # Shortcut when nothing is to be done. + foreach {pv fv} $args break + upvar 1 $pv pass $fv fail + if {[::llength $sequence] == 0} { + set pass {} + set fail {} + return {0 0} + } + foreach {pass fail} [uplevel 1 [ + ::list ::struct::list::Lfold $sequence {} [ + ::list ::struct::list::PFTest $cmdprefix]]] break + return [::list [llength $pass] [llength $fail]] + } else { + return -code error \ + "wrong#args: should be \"::struct::list::Lsplit sequence cmdprefix ?passVar failVar?" + } +} + +proc ::struct::list::PFTest {cmdprefix result item} { + set passing [uplevel 1 [::linsert $cmdprefix end $item]] + set pass {} ; set fail {} + foreach {pass fail} $result break + if {$passing} { + ::lappend pass $item + } else { + ::lappend fail $item + } + return [::list $pass $fail] +} + +# ::struct::list::Lfold -- +# +# Fold list into one value. +# +# Parameters: +# sequence List to operate on +# cmdprefix Operation to perform on the elements. +# +# Results: +# Result of applying cmdprefix to the elements of the +# sequence. +# +# Side effects: +# None of its own, but the command prefix can perform arbitry actions. + +proc ::struct::list::Lfold {sequence initialvalue cmdprefix} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $initialvalue} + + set res $initialvalue + foreach item $sequence { + set res [uplevel 1 [linsert $cmdprefix end $res $item]] + } + return $res +} + +# ::struct::list::Liota -- +# +# Return a list containing the integer numbers 0 ... n-1 +# +# Parameters: +# n First number not in the generated list. +# +# Results: +# A list containing integer numbers. +# +# Side effects: +# None + +proc ::struct::list::Liota {n} { + set retval [::list] + for {set i 0} {$i < $n} {incr i} { + ::lappend retval $i + } + return $retval +} + +# ::struct::list::Ldelete -- +# +# Delete an element from a list by name. +# Similar to 'struct::set exclude', however +# this here preserves order and list intrep. +# +# Parameters: +# a First list to compare. +# b Second list to compare. +# +# Results: +# A boolean. True if the lists are delete. +# +# Side effects: +# None + +proc ::struct::list::Ldelete {var item} { + upvar 1 $var list + set pos [lsearch -exact $list $item] + if {$pos < 0} return + set list [lreplace [K $list [set list {}]] $pos $pos] + return +} + +# ::struct::list::Lequal -- +# +# Compares two lists for equality +# (Same length, Same elements in same order). +# +# Parameters: +# a First list to compare. +# b Second list to compare. +# +# Results: +# A boolean. True if the lists are equal. +# +# Side effects: +# None + +proc ::struct::list::Lequal {a b} { + # Author of this command is "Richard Suchenwirth" + + if {[::llength $a] != [::llength $b]} {return 0} + if {[::lindex $a 0] == $a && [::lindex $b 0] == $b} {return [string equal $a $b]} + foreach i $a j $b {if {![Lequal $i $j]} {return 0}} + return 1 +} + +# ::struct::list::Lrepeatn -- +# +# Create a list repeating the same value over again. +# +# Parameters: +# value value to use in the created list. +# args Dimension(s) of the (nested) list to create. +# +# Results: +# A list +# +# Side effects: +# None + +proc ::struct::list::Lrepeatn {value args} { + if {[::llength $args] == 1} {set args [::lindex $args 0]} + set buf {} + foreach number $args { + incr number 0 ;# force integer (1) + set buf {} + for {set i 0} {$i<$number} {incr i} { + ::lappend buf $value + } + set value $buf + } + return $buf + # (1): See 'Stress testing' (wiki) for why this makes the code safer. +} + +# ::struct::list::Lrepeat -- +# +# Create a list repeating the same value over again. +# [Identical to the Tcl 8.5 lrepeat command] +# +# Parameters: +# n Number of replications. +# args values to use in the created list. +# +# Results: +# A list +# +# Side effects: +# None + +# Do a compatibility version of [repeat] for pre-8.5 versions of Tcl. + +if { [package vcompare [package provide Tcl] 8.5] < 0 } { + + proc ::struct::list::Lrepeat {positiveCount value args} { + if {![string is integer -strict $positiveCount]} { + return -code error "expected integer but got \"$positiveCount\"" + } elseif {$positiveCount < 1} { + return -code error {must have a count of at least 1} + } + + set args [linsert $args 0 $value] + + if {$positiveCount == 1} { + # Tcl itself has already listified the incoming parameters + # via 'args'. + return $args + } + + set result [::list] + while {$positiveCount > 0} { + if {($positiveCount % 2) == 0} { + set args [concat $args $args] + set positiveCount [expr {$positiveCount/2}] + } else { + set result [concat $result $args] + incr positiveCount -1 + } + } + return $result + } + +} else { + # For 8.5 simply redirect the method to the core command. + + interp alias {} ::struct::list::Lrepeat {} lrepeat +} + +# ::struct::list::LdbJoin(Keyed) -- +# +# Relational table joins. +# +# Parameters: +# args key specs and tables to join +# +# Results: +# A table/matrix as nested list. See +# struct/matrix set/get rect for structure. +# +# Side effects: +# None + +proc ::struct::list::LdbJoin {args} { + # -------------------------------- + # Process options ... + + set mode inner + set keyvar {} + + while {[llength $args]} { + set err [::cmdline::getopt args {inner left right full keys.arg} opt arg] + if {$err == 1} { + if {[string equal $opt keys]} { + set keyvar $arg + } else { + set mode $opt + } + } elseif {$err < 0} { + return -code error "wrong#args: dbJoin ?-inner|-left|-right|-full? ?-keys varname? \{key table\}..." + } else { + # Non-option argument found, stop processing. + break + } + } + + set inner [string equal $mode inner] + set innerorleft [expr {$inner || [string equal $mode left]}] + + # -------------------------------- + # Process tables ... + + if {([llength $args] % 2) != 0} { + return -code error "wrong#args: dbJoin ?-inner|-left|-right|-full? \{key table\}..." + } + + # One table only, join is identity + if {[llength $args] == 2} {return [lindex $args 1]} + + # Use first table for setup. + + foreach {key table} $args break + + # Check for possible early abort + if {$innerorleft && ([llength $table] == 0)} {return {}} + + set width 0 + array set state {} + + set keylist [InitMap state width $key $table] + + # Extend state with the remaining tables. + + foreach {key table} [lrange $args 2 end] { + # Check for possible early abort + if {$inner && ([llength $table] == 0)} {return {}} + + switch -exact -- $mode { + inner {set keylist [MapExtendInner state $key $table]} + left {set keylist [MapExtendLeftOuter state width $key $table]} + right {set keylist [MapExtendRightOuter state width $key $table]} + full {set keylist [MapExtendFullOuter state width $key $table]} + } + + # Check for possible early abort + if {$inner && ([llength $keylist] == 0)} {return {}} + } + + if {[string length $keyvar]} { + upvar 1 $keyvar keys + set keys $keylist + } + + return [MapToTable state $keylist] +} + +proc ::struct::list::LdbJoinKeyed {args} { + # -------------------------------- + # Process options ... + + set mode inner + set keyvar {} + + while {[llength $args]} { + set err [::cmdline::getopt args {inner left right full keys.arg} opt arg] + if {$err == 1} { + if {[string equal $opt keys]} { + set keyvar $arg + } else { + set mode $opt + } + } elseif {$err < 0} { + return -code error "wrong#args: dbJoin ?-inner|-left|-right|-full? table..." + } else { + # Non-option argument found, stop processing. + break + } + } + + set inner [string equal $mode inner] + set innerorleft [expr {$inner || [string equal $mode left]}] + + # -------------------------------- + # Process tables ... + + # One table only, join is identity + if {[llength $args] == 1} { + return [Dekey [lindex $args 0]] + } + + # Use first table for setup. + + set table [lindex $args 0] + + # Check for possible early abort + if {$innerorleft && ([llength $table] == 0)} {return {}} + + set width 0 + array set state {} + + set keylist [InitKeyedMap state width $table] + + # Extend state with the remaining tables. + + foreach table [lrange $args 1 end] { + # Check for possible early abort + if {$inner && ([llength $table] == 0)} {return {}} + + switch -exact -- $mode { + inner {set keylist [MapKeyedExtendInner state $table]} + left {set keylist [MapKeyedExtendLeftOuter state width $table]} + right {set keylist [MapKeyedExtendRightOuter state width $table]} + full {set keylist [MapKeyedExtendFullOuter state width $table]} + } + + # Check for possible early abort + if {$inner && ([llength $keylist] == 0)} {return {}} + } + + if {[string length $keyvar]} { + upvar 1 $keyvar keys + set keys $keylist + } + + return [MapToTable state $keylist] +} + +## Helpers for the relational joins. +## Map is an array mapping from keys to a list +## of rows with that key + +proc ::struct::list::Cartesian {leftmap rightmap key} { + upvar $leftmap left $rightmap right + set joined [::list] + foreach lrow $left($key) { + foreach row $right($key) { + lappend joined [concat $lrow $row] + } + } + set left($key) $joined + return +} + +proc ::struct::list::SingleRightCartesian {mapvar key rightrow} { + upvar $mapvar map + set joined [::list] + foreach lrow $map($key) { + lappend joined [concat $lrow $rightrow] + } + set map($key) $joined + return +} + +proc ::struct::list::MapToTable {mapvar keys} { + # Note: keys must not appear multiple times in the list. + + upvar $mapvar map + set table [::list] + foreach k $keys { + foreach row $map($k) {lappend table $row} + } + return $table +} + +## More helpers, core join operations: Init, Extend. + +proc ::struct::list::InitMap {mapvar wvar key table} { + upvar $mapvar map $wvar width + set width [llength [lindex $table 0]] + foreach row $table { + set keyval [lindex $row $key] + if {[info exists map($keyval)]} { + lappend map($keyval) $row + } else { + set map($keyval) [::list $row] + } + } + return [array names map] +} + +proc ::struct::list::MapExtendInner {mapvar key table} { + upvar $mapvar map + array set used {} + + # Phase I - Find all keys in the second table matching keys in the + # first. Remember all their rows. + foreach row $table { + set keyval [lindex $row $key] + if {[info exists map($keyval)]} { + if {[info exists used($keyval)]} { + lappend used($keyval) $row + } else { + set used($keyval) [::list $row] + } + } ; # else: Nothing to do for missing keys. + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map, and eliminate all entries which have no keys in + # the second table. + foreach k [array names map] { + if {[info exists used($k)]} { + Cartesian map used $k + } else { + unset map($k) + } + } + return [array names map] +} + +proc ::struct::list::MapExtendRightOuter {mapvar wvar key table} { + upvar $mapvar map $wvar width + array set used {} + + # Phase I - We keep all keys of the right table, even if they are + # missing in the left one <=> Definition of right outer join. + + set w [llength [lindex $table 0]] + foreach row $table { + set keyval [lindex $row $key] + if {[info exists used($keyval)]} { + lappend used($keyval) $row + } else { + set used($keyval) [::list $row] + } + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map, and eliminate all entries which have no keys in + # the second table. If there is nothing in the left table we + # create an appropriate empty row for the cartesian => definition + # of right outer join. + + # We go through used, because map can be empty for outer + + foreach k [array names map] { + if {![info exists used($k)]} { + unset map($k) + } + } + foreach k [array names used] { + if {![info exists map($k)]} { + set map($k) [::list [Lrepeatn {} $width]] + } + Cartesian map used $k + } + + incr width $w + return [array names map] +} + +proc ::struct::list::MapExtendLeftOuter {mapvar wvar key table} { + upvar $mapvar map $wvar width + array set used {} + + ## Keys: All in inner join + additional left keys + ## == All left keys = array names map after + ## all is said and done with it. + + # Phase I - Find all keys in the second table matching keys in the + # first. Remember all their rows. + set w [llength [lindex $table 0]] + foreach row $table { + set keyval [lindex $row $key] + if {[info exists map($keyval)]} { + if {[info exists used($keyval)]} { + lappend used($keyval) $row + } else { + set used($keyval) [::list $row] + } + } ; # else: Nothing to do for missing keys. + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map. We keep entries which have no keys in the second + # table, we actually extend them <=> Left outer join. + + foreach k [array names map] { + if {[info exists used($k)]} { + Cartesian map used $k + } else { + SingleRightCartesian map $k [Lrepeatn {} $w] + } + } + incr width $w + return [array names map] +} + +proc ::struct::list::MapExtendFullOuter {mapvar wvar key table} { + upvar $mapvar map $wvar width + array set used {} + + # Phase I - We keep all keys of the right table, even if they are + # missing in the left one <=> Definition of right outer join. + + set w [llength [lindex $table 0]] + foreach row $table { + set keyval [lindex $row $key] + if {[info exists used($keyval)]} { + lappend used($keyval) $row + } else { + lappend keylist $keyval + set used($keyval) [::list $row] + } + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map. We keep entries which have no keys in the second + # table, we actually extend them <=> Left outer join. + # If there is nothing in the left table we create an appropriate + # empty row for the cartesian => definition of right outer join. + + # We go through used, because map can be empty for outer + + foreach k [array names map] { + if {![info exists used($k)]} { + SingleRightCartesian map $k [Lrepeatn {} $w] + } + } + foreach k [array names used] { + if {![info exists map($k)]} { + set map($k) [::list [Lrepeatn {} $width]] + } + Cartesian map used $k + } + + incr width $w + return [array names map] +} + +## Keyed helpers + +proc ::struct::list::InitKeyedMap {mapvar wvar table} { + upvar $mapvar map $wvar width + set width [llength [lindex [lindex $table 0] 1]] + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists map($keyval)]} { + lappend map($keyval) $rowdata + } else { + set map($keyval) [::list $rowdata] + } + } + return [array names map] +} + +proc ::struct::list::MapKeyedExtendInner {mapvar table} { + upvar $mapvar map + array set used {} + + # Phase I - Find all keys in the second table matching keys in the + # first. Remember all their rows. + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists map($keyval)]} { + if {[info exists used($keyval)]} { + lappend used($keyval) $rowdata + } else { + set used($keyval) [::list $rowdata] + } + } ; # else: Nothing to do for missing keys. + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map, and eliminate all entries which have no keys in + # the second table. + foreach k [array names map] { + if {[info exists used($k)]} { + Cartesian map used $k + } else { + unset map($k) + } + } + + return [array names map] +} + +proc ::struct::list::MapKeyedExtendRightOuter {mapvar wvar table} { + upvar $mapvar map $wvar width + array set used {} + + # Phase I - We keep all keys of the right table, even if they are + # missing in the left one <=> Definition of right outer join. + + set w [llength [lindex $table 0]] + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists used($keyval)]} { + lappend used($keyval) $rowdata + } else { + set used($keyval) [::list $rowdata] + } + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map, and eliminate all entries which have no keys in + # the second table. If there is nothing in the left table we + # create an appropriate empty row for the cartesian => definition + # of right outer join. + + # We go through used, because map can be empty for outer + + foreach k [array names map] { + if {![info exists used($k)]} { + unset map($k) + } + } + foreach k [array names used] { + if {![info exists map($k)]} { + set map($k) [::list [Lrepeatn {} $width]] + } + Cartesian map used $k + } + + incr width $w + return [array names map] +} + +proc ::struct::list::MapKeyedExtendLeftOuter {mapvar wvar table} { + upvar $mapvar map $wvar width + array set used {} + + ## Keys: All in inner join + additional left keys + ## == All left keys = array names map after + ## all is said and done with it. + + # Phase I - Find all keys in the second table matching keys in the + # first. Remember all their rows. + set w [llength [lindex $table 0]] + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists map($keyval)]} { + if {[info exists used($keyval)]} { + lappend used($keyval) $rowdata + } else { + set used($keyval) [::list $rowdata] + } + } ; # else: Nothing to do for missing keys. + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map. We keep entries which have no keys in the second + # table, we actually extend them <=> Left outer join. + + foreach k [array names map] { + if {[info exists used($k)]} { + Cartesian map used $k + } else { + SingleRightCartesian map $k [Lrepeatn {} $w] + } + } + incr width $w + return [array names map] +} + +proc ::struct::list::MapKeyedExtendFullOuter {mapvar wvar table} { + upvar $mapvar map $wvar width + array set used {} + + # Phase I - We keep all keys of the right table, even if they are + # missing in the left one <=> Definition of right outer join. + + set w [llength [lindex $table 0]] + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists used($keyval)]} { + lappend used($keyval) $rowdata + } else { + lappend keylist $keyval + set used($keyval) [::list $rowdata] + } + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map. We keep entries which have no keys in the second + # table, we actually extend them <=> Left outer join. + # If there is nothing in the left table we create an appropriate + # empty row for the cartesian => definition of right outer join. + + # We go through used, because map can be empty for outer + + foreach k [array names map] { + if {![info exists used($k)]} { + SingleRightCartesian map $k [Lrepeatn {} $w] + } + } + foreach k [array names used] { + if {![info exists map($k)]} { + set map($k) [::list [Lrepeatn {} $width]] + } + Cartesian map used $k + } + + incr width $w + return [array names map] +} + +proc ::struct::list::Dekey {keyedtable} { + set table [::list] + foreach row $keyedtable {lappend table [lindex $row 1]} + return $table +} + +# ::struct::list::Lswap -- +# +# Exchange two elements of a list. +# +# Parameters: +# listvar Name of the variable containing the list to manipulate. +# i, j Indices of the list elements to exchange. +# +# Results: +# The modified list +# +# Side effects: +# None + +proc ::struct::list::Lswap {listvar i j} { + upvar $listvar list + + if {($i < 0) || ($j < 0)} { + return -code error {list index out of range} + } + set len [llength $list] + if {($i >= $len) || ($j >= $len)} { + return -code error {list index out of range} + } + + if {$i != $j} { + set tmp [lindex $list $i] + lset list $i [lindex $list $j] + lset list $j $tmp + } + return $list +} + +# ::struct::list::Lfirstperm -- +# +# Returns the lexicographically first permutation of the +# specified list. +# +# Parameters: +# list The list whose first permutation is sought. +# +# Results: +# A modified list containing the lexicographically first +# permutation of the input. +# +# Side effects: +# None + +proc ::struct::list::Lfirstperm {list} { + return [lsort $list] +} + +# ::struct::list::Lnextperm -- +# +# Accepts a permutation of a set of elements and returns the +# next permutatation in lexicographic sequence. +# +# Parameters: +# list The list containing the current permutation. +# +# Results: +# A modified list containing the lexicographically next +# permutation after the input permutation. +# +# Side effects: +# None + +proc ::struct::list::Lnextperm {perm} { + # Find the smallest subscript j such that we have already visited + # all permutations beginning with the first j elements. + + set len [expr {[llength $perm] - 1}] + + set j $len + set ajp1 [lindex $perm $j] + while { $j > 0 } { + incr j -1 + set aj [lindex $perm $j] + if { [string compare $ajp1 $aj] > 0 } { + set foundj {} + break + } + set ajp1 $aj + } + if { ![info exists foundj] } return + + # Find the smallest element greater than the j'th among the elements + # following aj. Let its index be l, and interchange aj and al. + + set l $len + while { [string compare $aj [set al [lindex $perm $l]]] >= 0 } { + incr l -1 + } + lset perm $j $al + lset perm $l $aj + + # Reverse a_j+1 ... an + + set k [expr {$j + 1}] + set l $len + while { $k < $l } { + set al [lindex $perm $l] + lset perm $l [lindex $perm $k] + lset perm $k $al + incr k + incr l -1 + } + + return $perm +} + +# ::struct::list::Lpermutations -- +# +# Returns a list containing all the permutations of the +# specified list, in lexicographic order. +# +# Parameters: +# list The list whose permutations are sought. +# +# Results: +# A list of lists, containing all permutations of the +# input. +# +# Side effects: +# None + +proc ::struct::list::Lpermutations {list} { + + if {[llength $list] < 2} { + return [::list $list] + } + + set res {} + set p [Lfirstperm $list] + while {[llength $p]} { + lappend res $p + set p [Lnextperm $p] + } + return $res +} + +# ::struct::list::Lforeachperm -- +# +# Executes a script for all the permutations of the +# specified list, in lexicographic order. +# +# Parameters: +# var Name of the loop variable. +# list The list whose permutations are sought. +# body The tcl script to run per permutation of +# the input. +# +# Results: +# The empty string. +# +# Side effects: +# None + +proc ::struct::list::Lforeachperm {var list body} { + upvar $var loopvar + + if {[llength $list] < 2} { + set loopvar $list + # TODO run body. + + # The first invocation of the body, also the last, as only one + # permutation is possible. That makes handling of the result + # codes easier. + + set code [catch {uplevel 1 $body} result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel foreachperm] \ + -errorcode $::errorCode -code error $result + } + 3 {} + 4 {} + default { + # Includes code 2 + return -code $code $result + } + } + return + } + + set p [Lfirstperm $list] + while {[llength $p]} { + set loopvar $p + + set code [catch {uplevel 1 $body} result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel foreachperm] \ + -errorcode $::errorCode -code error $result + } + 3 { + # FRINK: nocheck + return + } + 4 {} + default { + return -code $code $result + } + } + set p [Lnextperm $p] + } + return +} + +proc ::struct::list::Lshuffle {list} { + for {set i [llength $list]} {$i > 1} {lset list $j $t} { + set j [expr {int(rand() * $i)}] + set t [lindex $list [incr i -1]] + lset list $i [lindex $list $j] + } + return $list +} + +# ### ### ### ######### ######### ######### + +proc ::struct::list::ErrorInfoAsCaller {find replace} { + set info $::errorInfo + set i [string last "\n (\"$find" $info] + if {$i == -1} {return $info} + set result [string range $info 0 [incr i 6]] ;# keep "\n (\"" + append result $replace ;# $find -> $replace + incr i [string length $find] + set j [string first ) $info [incr i]] ;# keep rest of parenthetical + append result [string range $info $i $j] + return $result +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'list::list' into the general structure namespace. + namespace import -force list::list + namespace export list +} +package provide struct::list 1.8.6 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/list.test.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/list.test.tcl new file mode 100644 index 00000000..924c3108 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/list.test.tcl @@ -0,0 +1,1268 @@ + +namespace eval ::struct::list::test {} + +proc ::struct::list::test::main {} { + test list-lcs-1.1 {longestCommonSubsequence, no args} { + catch { lcs } msg + set msg + } [tcltest::wrongNumArgs ::struct::list::LlongestCommonSubsequence \ + {sequence1 sequence2 ?maxOccurs?} 0] + + test list-lcs-1.2 {longestCommonSubsequence, one arg} { + catch { lcs x } msg + set msg + } [tcltest::wrongNumArgs ::struct::list::LlongestCommonSubsequence \ + {sequence1 sequence2 ?maxOccurs?} 1] + + test list-lcs-2.1 {longestCommonSubsequence, two empty lists} { + list [catch { lcs {} {} } msg] $msg + } {0 {{} {}}} + + test list-lcs-2.2 {longestCommonSubsequence, insert 1 into an empty list} { + list [catch { lcs {} {a} } msg] $msg + } {0 {{} {}}} + + test list-lcs-2.3 {longestCommonSubsequence, delete 1 from singleton list} { + list [catch { lcs {a} {} } msg] $msg + } {0 {{} {}}} + + test list-lcs-2.4 {longestCommonSubsequence, preserve singleton list} { + list [catch { lcs {a} {a} } msg] $msg + } {0 {0 0}} + + test list-lcs-2.5 {longestCommonSubsequence, 1-element change in singleton list} { + list [catch { lcs {a} {b} } msg] $msg + } {0 {{} {}}} + + test list-lcs-2.6 {longestCommonSubsequence, insert 1 in front of singleton list} { + list [catch { lcs {a} {b a} } msg] $msg + } {0 {0 1}} + + test list-lcs-2.7 {longestCommonSubsequence, insert 1 at end of singleton list} { + list [catch {lcs {a} {a b}} msg] $msg + } {0 {0 0}} + + test list-lcs-2.8 {longestCommonSubsequence, duplicate element} { + list [catch {lcs {a} {a a}} msg] $msg + } {0 {0 0}} + + test list-lcs-2.9 {longestCommonSubsequence, interchange 2} { + list [catch {lcs {a b} {b a}} msg] $msg + } {0 {1 0}} + + test list-lcs-2.10 {longestCommonSubsequence, insert before 2} { + list [catch {lcs {a b} {b a b}} msg] $msg + } {0 {{0 1} {1 2}}} + + test list-lcs-2.11 {longestCommonSubsequence, insert inside 2} { + list [catch {lcs {a b} {a a b}} msg] $msg + } {0 {{0 1} {0 2}}} + + test list-lcs-2.12 {longestCommonSubsequence, insert after 2} { + list [catch {lcs {a b} {a b a}} msg] $msg + } {0 {{0 1} {0 1}}} + + test list-lcs-2.13 {longestCommonSubsequence, delete first of 2} { + list [catch {lcs {a b} b} msg] $msg + } {0 {1 0}} + + test list-lcs-2.14 {longestCommonSubsequence, delete second of 2} { + list [catch {lcs {a b} a} msg] $msg + } {0 {0 0}} + + test list-lcs-2.15 {longestCommonSubsequence, change first of 2} { + list [catch {lcs {a b} {c b}} msg] $msg + } {0 {1 1}} + + test list-lcs-2.16 {longestCommonSubsequence, change first of 2 to dupe} { + list [catch {lcs {a b} {b b}} msg] $msg + } {0 {1 0}} + + test list-lcs-2.17 {longestCommonSubsequence, change second of 2} { + list [catch {lcs {a b} {a c}} msg] $msg + } {0 {0 0}} + + test list-lcs-2.18 {longestCommonSubsequence, change second of 2 to dupe} { + list [catch {lcs {a b} {a a}} msg] $msg + } {0 {0 0}} + + test list-lcs-2.19 {longestCommonSubsequence, mixed changes} { + list [catch {lcs {a b r a c a d a b r a} {b r i c a b r a c}} msg] $msg + } {0 {{1 2 4 5 8 9 10} {0 1 3 4 5 6 7}}} + + test list-lcs-2.20 {longestCommonSubsequence, mixed changes} { + list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a}} msg] $msg + } {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + + test list-lcs-3.1 {longestCommonSubsequence, length limit} { + list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 5} msg] $msg + } {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + + test list-lcs-3.2 {longestCommonSubsequence, length limit} { + list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 4} msg] $msg + } {0 {{0 1 3 5 6} {1 2 4 8 9}}} + + test list-lcs-3.3 {longestCommonSubsequence, length limit} { + list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 1} msg] $msg + } {0 {3 4}} + + test list-lcs-3.4 {longestCommonSubsequence, stupid length limit} { + list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 0} msg] $msg + } {0 {{} {}}} + + + #---------------------------------------------------------------------- + + interp alias {} lcs2 {} ::struct::list::list longestCommonSubsequence2 + + test list-lcs2-1.1 {longestCommonSubsequence2, no args} { + catch { lcs2 } msg + set msg + } [tcltest::wrongNumArgs ::struct::list::LlongestCommonSubsequence2 \ + {sequence1 sequence2 ?maxOccurs?} 0] + + test list-lcs2-1.2 {longestCommonSubsequence2, one arg} { + catch { lcs2 x } msg + set msg + } [tcltest::wrongNumArgs ::struct::list::LlongestCommonSubsequence2 \ + {sequence1 sequence2 ?maxOccurs?} 1] + + test list-lcs2-2.1 {longestCommonSubsequence2, two empty lists} { + list [catch { lcs2 {} {} } msg] $msg + } {0 {{} {}}} + + test list-lcs2-2.2 {longestCommonSubsequence2, insert 1 into an empty list} { + list [catch { lcs2 {} {a} } msg] $msg + } {0 {{} {}}} + + test list-lcs2-2.3 {longestCommonSubsequence2, delete 1 from singleton list} { + list [catch { lcs2 {a} {} } msg] $msg + } {0 {{} {}}} + + test list-lcs2-2.4 {longestCommonSubsequence2, preserve singleton list} { + list [catch { lcs2 {a} {a} } msg] $msg + } {0 {0 0}} + + test list-lcs2-2.5 {longestCommonSubsequence2, 1-element change in singleton list} { + list [catch { lcs2 {a} {b} } msg] $msg + } {0 {{} {}}} + + test list-lcs2-2.6 {longestCommonSubsequence2, insert 1 in front of singleton list} { + list [catch { lcs2 {a} {b a} } msg] $msg + } {0 {0 1}} + + test list-lcs2-2.7 {longestCommonSubsequence2, insert 1 at end of singleton list} { + list [catch {lcs2 {a} {a b}} msg] $msg + } {0 {0 0}} + + test list-lcs2-2.8 {longestCommonSubsequence2, duplicate element} { + list [catch {lcs2 {a} {a a}} msg] $msg + } {0 {0 0}} + + test list-lcs2-2.9 {longestCommonSubsequence2, interchange 2} { + list [catch {lcs2 {a b} {b a}} msg] $msg + } {0 {1 0}} + + test list-lcs2-2.10 {longestCommonSubsequence2, insert before 2} { + list [catch {lcs2 {a b} {b a b}} msg] $msg + } {0 {{0 1} {1 2}}} + + test list-lcs2-2.11 {longestCommonSubsequence2, insert inside 2} { + list [catch {lcs2 {a b} {a a b}} msg] $msg + } {0 {{0 1} {0 2}}} + + test list-lcs2-2.12 {longestCommonSubsequence2, insert after 2} { + list [catch {lcs2 {a b} {a b a}} msg] $msg + } {0 {{0 1} {0 1}}} + + test list-lcs2-2.13 {longestCommonSubsequence2, delete first of 2} { + list [catch {lcs2 {a b} a} msg] $msg + } {0 {0 0}} + + test list-lcs2-2.14 {longestCommonSubsequence2, delete second of 2} { + list [catch {lcs2 {a b} b} msg] $msg + } {0 {1 0}} + + test list-lcs2-2.15 {longestCommonSubsequence2, change first of 2} { + list [catch {lcs2 {a b} {c b}} msg] $msg + } {0 {1 1}} + + test list-lcs2-2.16 {longestCommonSubsequence2, change first of 2 to dupe} { + list [catch {lcs2 {a b} {b b}} msg] $msg + } {0 {1 0}} + + test list-lcs2-2.17 {longestCommonSubsequence2, change second of 2} { + list [catch {lcs2 {a b} {a c}} msg] $msg + } {0 {0 0}} + + test list-lcs2-2.18 {longestCommonSubsequence2, change second of 2 to dupe} { + list [catch {lcs2 {a b} {a a}} msg] $msg + } {0 {0 0}} + + test list-lcs2-2.19 {longestCommonSubsequence2, mixed changes} { + list [catch {lcs2 {a b r a c a d a b r a} {b r i c a b r a c}} msg] $msg + } {0 {{1 2 4 5 8 9 10} {0 1 3 4 5 6 7}}} + + test list-lcs2-2.20 {longestCommonSubsequence2, mixed changes} { + list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a}} msg] $msg + } {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + + test list-lcs2-3.1 {longestCommonSubsequence2, length limit} { + list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 5} msg] $msg + } {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + + test list-lcs2-3.2 {longestCommonSubsequence2, length limit} { + list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 4} msg] $msg + } {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + + test list-lcs2-3.3 {longestCommonSubsequence2, length limit} { + list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 1} msg] $msg + } {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + + test list-lcs2-3.4 {longestCommonSubsequence2, stupid length limit} { + list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 0} msg] $msg + } {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}} + + + #---------------------------------------------------------------------- + + interp alias {} lcsi {} ::struct::list::list lcsInvert + interp alias {} lcsim {} ::struct::list::list lcsInvertMerge + + test list-lcsInv-4.0 {longestCommonSubsequence, mixed changes} { + + # sequence 1 = a b r a c a d a b r a + # lcs 1 = 1 2 4 5 8 9 10 + # lcs 2 = 0 1 3 4 5 6 7 + # sequence 2 = b r i c a b r a c + # + # Inversion = deleted {0 0} {-1 0} + # changed {3 3} {2 2} + # deleted {6 7} {4 5} + # added {10 11} {8 8} + + list [catch {lcsi [lcs {a b r a c a d a b r a} {b r i c a b r a c}] 11 9} msg] $msg + } {0 {{deleted {0 0} {-1 0}} {changed {3 3} {2 2}} {deleted {6 7} {4 5}} {added {10 11} {8 8}}}} + + test list-lcsInv-4.1 {longestCommonSubsequence, mixed changes} { + + # sequence 1 = a b r a c a d a b r a + # lcs 1 = 1 2 4 5 8 9 10 + # lcs 2 = 0 1 3 4 5 6 7 + # sequence 2 = b r i c a b r a c + # + # Inversion/Merge = deleted {0 0} {-1 0} + # unchanged {1 2} {0 1} + # changed {3 3} {2 2} + # unchanged {4 5} {3 4} + # deleted {6 7} {4 5} + # unchanged {8 10} {5 7} + # added {10 11} {8 8} + + list [catch {lcsim [lcs {a b r a c a d a b r a} {b r i c a b r a c}] 11 9} msg] $msg + } {0 {{deleted {0 0} {-1 0}} {unchanged {1 2} {0 1}} {changed {3 3} {2 2}} {unchanged {4 5} {3 4}} {deleted {6 7} {4 5}} {unchanged {8 10} {5 7}} {added {10 11} {8 8}}}} + + + proc diff2 {s1 s2} { + set l1 [split $s1 {}] + set l2 [split $s2 {}] + set x [lcs $l1 $l2] + lcsim $x [llength $l1] [llength $l2] + } + test list-lcsInv-4.2 {lcsInvertMerge} { + # Handling of 'unchanged' chunks at the beginning of the result + # (when result actually empty). + + diff2 ab "a b" + } {{unchanged {0 0} {0 0}} {added {0 1} {1 1}} {unchanged {1 1} {2 2}}} + + test list-lcsInv-4.3 {lcsInvertMerge} { + diff2 abcde afcge + } {{unchanged {0 0} {0 0}} {changed {1 1} {1 1}} {unchanged {2 2} {2 2}} {changed {3 3} {3 3}} {unchanged {4 4} {4 4}}} + + #---------------------------------------------------------------------- + + interp alias {} reverse {} ::struct::list::list reverse + + test reverse-1.1 {reverse method} { + reverse {a b c} + } {c b a} + + test reverse-1.2 {reverse method} { + reverse a + } {a} + + test reverse-1.3 {reverse method} { + reverse {} + } {} + + test reverse-2.1 {reverse errors} { + list [catch {reverse} msg] $msg + } [list 1 [tcltest::wrongNumArgs ::struct::list::Lreverse {sequence} 0]] + + #---------------------------------------------------------------------- + + interp alias {} assign {} ::struct::list::list assign + + test assign-4.1 {assign method} { + catch {unset ::x ::y} + list [assign {foo bar} x y] $x $y + } {{} foo bar} + + test assign-4.2 {assign method} { + catch {unset x y} + list [assign {foo bar baz} x y] $x $y + } {baz foo bar} + + test assign-4.3 {assign method} { + catch {unset x y z} + list [assign {foo bar} x y z] $x $y $z + } {{} foo bar {}} + + if {[package vcompare [package provide Tcl] 8.5] < 0} { + # 8.4 + set err [tcltest::wrongNumArgs {::struct::list::Lassign} {sequence v args} 1] + } else { + # 8.5+ + #set err [tcltest::wrongNumArgs {lassign} {list varName ?varName ...?} 1] + set err [tcltest::wrongNumArgs {::struct::list::Lassign} {list varName ?varName ...?} 1] + } + + # In 8.6+ assign is the native lassign and it does nothing gracefully, + # per TIP 323, making assign-4.4 not an error anymore. + test assign-4.4 {assign method} tcl8.5only { + catch {assign {foo bar}} msg ; set msg + } $err + + test assign-4.5 {assign method} { + list [assign {foo bar} x] $x + } {bar foo} + + catch {unset x y z} + + #---------------------------------------------------------------------- + + interp alias {} flatten {} ::struct::list::list flatten + + test flatten-1.1 {flatten command} { + flatten {1 2 3 {4 5} {6 7} {{8 9}} 10} + } {1 2 3 4 5 6 7 {8 9} 10} + + test flatten-1.2 {flatten command} { + flatten -full {1 2 3 {4 5} {6 7} {{8 9}} 10} + } {1 2 3 4 5 6 7 8 9 10} + + test flatten-1.3 {flatten command} { + flatten {a b} + } {a b} + + test flatten-1.4 {flatten command} { + flatten [list "\[a\]" "\[b\]"] + } {{[a]} {[b]}} + + test flatten-1.5 {flatten command} { + flatten [list "'" "\""] + } {' {"}} ; # " help emacs highlighting + + test flatten-1.6 {flatten command} { + flatten [list "{" "}"] + } "\\\{ \\\}" + + test flatten-1.7 {check -- argument termination} { + flatten -full -- {1 2 3 {4 5} {6 7} {{8 9}} 10} + } {1 2 3 4 5 6 7 8 9 10} + + test flatten-2.1 {flatten errors} { + list [catch {flatten} msg] $msg + } {1 {wrong#args: should be "::struct::list::Lflatten ?-full? ?--? sequence"}} + + test flatten-2.2 {flatten errors} { + list [catch {flatten -all {a {b c d} {e {f g}}}} msg] $msg + } {1 {Unknown option "-all", should be either -full, or --}} + + + #---------------------------------------------------------------------- + + interp alias {} map {} ::struct::list::list map + + proc cc {a} {return $a$a} + proc + {a} {expr {$a + $a}} + proc * {a} {expr {$a * $a}} + proc projection {n list} {::lindex $list $n} + + test map-4.1 {map command} { + map {a b c d} cc + } {aa bb cc dd} + + test map-4.2 {map command} { + map {1 2 3 4 5} + + } {2 4 6 8 10} + + test map-4.3 {map command} { + map {1 2 3 4 5} * + } {1 4 9 16 25} + + test map-4.4 {map command} { + map {} * + } {} + + test map-4.5 {map command} { + map {{a b c} {1 2 3} {d f g}} {projection 1} + } {b 2 f} + + + #---------------------------------------------------------------------- + + interp alias {} mapfor {} ::struct::list::list mapfor + + test mapfor-4.1 {mapfor command} { + mapfor x {a b c d} { set x $x$x } + } {aa bb cc dd} + + test mapfor-4.2 {mapfor command} { + mapfor x {1 2 3 4 5} {expr {$x + $x}} + } {2 4 6 8 10} + + test mapfor-4.3 {mapfor command} { + mapfor x {1 2 3 4 5} {expr {$x * $x}} + } {1 4 9 16 25} + + test mapfor-4.4 {mapfor command} { + mapfor x {} {expr {$x * $x}} + } {} + + test mapfor-4.5 {mapfor command} { + mapfor x {{a b c} {1 2 3} {d f g}} {lindex $x 1} + } {b 2 f} + + #---------------------------------------------------------------------- + + interp alias {} fold {} ::struct::list::list fold + + proc cc {a b} {return $a$b} + proc + {a b} {expr {$a + $b}} + proc * {a b} {expr {$a * $b}} + + test fold-4.1 {fold command} { + fold {a b c d} {} cc + } {abcd} + + test fold-4.2 {fold command} { + fold {1 2 3 4 5} 0 + + } {15} + + test fold-4.3 {fold command} { + fold {1 2 3 4 5} 1 * + } {120} + + test fold-4.4 {fold command} { + fold {} 1 * + } {1} + + #---------------------------------------------------------------------- + + interp alias {} filter {} ::struct::list::list filter + + proc even {i} {expr {($i % 2) == 0}} + + test filter-4.1 {filter command} { + filter {1 2 3 4 5 6 7 8} even + } {2 4 6 8} + + test filter-4.2 {filter command} { + filter {} even + } {} + + test filter-4.3 {filter command} { + filter {3 5 7} even + } {} + + test filter-4.4 {filter command} { + filter {2 4 6} even + } {2 4 6} + + # Alternate which elements are filtered by using a global variable + # flag. Used to test that the `cmdprefix' is evaluated in the caller's + # scope. + # + # The flag variable should be set on the -setup phase. + + proc alternating {_} { + upvar 1 flag flag; + set flag [expr {!($flag)}]; + return $flag; + } + + test filter-4.5 {filter evaluates cmdprefix on outer scope} -setup { + set flag 1 + } -body { + filter {1 2 3 4 5 6} alternating + } -cleanup { + unset flag + } -result {2 4 6} + + #---------------------------------------------------------------------- + + interp alias {} filterfor {} ::struct::list::list filterfor + + test filterfor-4.1 {filterfor command} { + filterfor i {1 2 3 4 5 6 7 8} {($i % 2) == 0} + } {2 4 6 8} + + test filterfor-4.2 {filterfor command} { + filterfor i {} {($i % 2) == 0} + } {} + + test filterfor-4.3 {filterfor command} { + filterfor i {3 5 7} {($i % 2) == 0} + } {} + + test filterfor-4.4 {filterfor command} { + filterfor i {2 4 6} {($i % 2) == 0} + } {2 4 6} + + #---------------------------------------------------------------------- + + interp alias {} lsplit {} ::struct::list::list split + + proc even {i} {expr {($i % 2) == 0}} + + test split-4.1 {split command} { + lsplit {1 2 3 4 5 6 7 8} even + } {{2 4 6 8} {1 3 5 7}} + + test split-4.2 {split command} { + lsplit {} even + } {{} {}} + + test split-4.3 {split command} { + lsplit {3 5 7} even + } {{} {3 5 7}} + + test split-4.4 {split command} { + lsplit {2 4 6} even + } {{2 4 6} {}} + + test split-4.5 {split command} { + list [lsplit {1 2 3 4 5 6 7 8} even pass fail] $pass $fail + } {{4 4} {2 4 6 8} {1 3 5 7}} + + test split-4.6 {split command} { + list [lsplit {} even pass fail] $pass $fail + } {{0 0} {} {}} + + test split-4.7 {split command} { + list [lsplit {3 5 7} even pass fail] $pass $fail + } {{0 3} {} {3 5 7}} + + test split-4.8 {split command} { + list [lsplit {2 4 6} even pass fail] $pass $fail + } {{3 0} {2 4 6} {}} + + + # See test filter-4.5 for explanations. + + test split-4.9 {split evaluates cmdprefix on outer scope} -setup { + set flag 1 + } -body { + list [lsplit {1 2 3 4 5 6 7 8} alternating pass fail] $pass $fail + } -cleanup { + unset flag + } -result {{4 4} {2 4 6 8} {1 3 5 7}} + + #---------------------------------------------------------------------- + + interp alias {} shift {} ::struct::list::list shift + + test shift-4.1 {shift command} { + set v {1 2 3 4 5 6 7 8} + list [shift v] $v + } {1 {2 3 4 5 6 7 8}} + + test shift-4.2 {shift command} { + set v {1} + list [shift v] $v + } {1 {}} + + test shift-4.3 {shift command} { + set v {} + list [shift v] $v + } {{} {}} + + #---------------------------------------------------------------------- + + interp alias {} iota {} ::struct::list::list iota + + test iota-4.1 {iota command} { + iota 0 + } {} + + test iota-4.2 {iota command} { + iota 1 + } {0} + + test iota-4.3 {iota command} { + iota 11 + } {0 1 2 3 4 5 6 7 8 9 10} + + + #---------------------------------------------------------------------- + + interp alias {} repeatn {} ::struct::list::list repeatn + + test repeatn-4.1 {repeatn command} { + repeatn 0 + } {} + + test repeatn-4.2 {repeatn command} { + repeatn 0 3 + } {0 0 0} + + test repeatn-4.3 {repeatn command} { + repeatn 0 3 4 + } {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} + + test repeatn-4.4 {repeatn command} { + repeatn 0 {3 4} + } {{0 0 0} {0 0 0} {0 0 0} {0 0 0}} + + #---------------------------------------------------------------------- + + interp alias {} repeat {} ::struct::list::list repeat + + test repeat-4.1 {repeat command} { + catch {repeat} msg + set msg + } [tcltest::byConstraint [list \ + tcl8.6plus [tcltest::wrongNumArgs {::struct::list::Lrepeat} {count ?value ...?} 1] \ + tcl8.5only [tcltest::wrongNumArgs {::struct::list::Lrepeat} {positiveCount value ?value ...?} 0]]] + + + # In 8.6+ repeat is the native lrepeat and it does nothing gracefully, + # per TIP 323, making repeat-4.2 not an error anymore. + test repeat-4.2 {repeat command} tcl8.5only { + catch {repeat a} msg + set msg + } [tcltest::wrongNumArgs {::struct::list::Lrepeat} {positiveCount value ?value ...?} 1] + + test repeat-4.3 {repeat command} { + catch {repeat a b} msg + set msg + } {expected integer but got "a"} + + # In 8.6+ repeat is the native lrepeat and it does nothing gracefully, + # per TIP 323, making repeat-4.2 not an error anymore. + test repeat-4.4 {repeat command} tcl8.5only { + catch {repeat 0 b} msg + set msg + } {must have a count of at least 1} + + test repeat-4.5 {repeat command} { + catch {repeat -1 b} msg + set msg + } [tcltest::byConstraint { + tcl8.6plus {bad count "-1": must be integer >= 0} + tcl8.5only {must have a count of at least 1} + }] + + test repeat-4.6 {repeat command} { + repeat 1 b c + } {b c} + + test repeat-4.7 {repeat command} { + repeat 3 a + } {a a a} + + test repeat-4.8 {repeat command} { + repeat 3 [repeat 3 0] + } {{0 0 0} {0 0 0} {0 0 0}} + + test repeat-4.9 {repeat command} { + repeat 3 a b c + } {a b c a b c a b c} + + test repeat-4.10 {repeat command} { + repeat 3 [repeat 2 a] b c + } {{a a} b c {a a} b c {a a} b c} + + #---------------------------------------------------------------------- + + interp alias {} equal {} ::struct::list::list equal + + test equal-4.1 {equal command} { + equal 0 0 + } 1 + + test equal-4.2 {equal command} { + equal 0 1 + } 0 + + test equal-4.3 {equal command} { + equal {0 0 0} {0 0} + } 0 + + test equal-4.4 {equal command} { + equal {{0 2 3} 1} {{0 2 3} 1} + } 1 + + test equal-4.5 {equal command} { + equal [list [list a]] {{a}} + } 1 + + test equal-4.6 {equal command} { + equal {{a}} [list [list a]] + } 1 + + test equal-4.7 {equal command} { + set a {{a}} + set b [list [list a]] + expr {[equal $a $b] == [equal $b $a]} + } 1 + + test equal-4.8 {equal command} { + set a {{a b}} + set b [list [list a b]] + expr {[equal $a $b] == [equal $b $a]} + } 1 + + test equal-4.9 {equal command} { + set a {{a} {b}} + set b [list [list a] [list b]] + expr {[equal $a $b] == [equal $b $a]} + } 1 + + #---------------------------------------------------------------------- + + interp alias {} delete {} ::struct::list::list delete + + test delete-1.0 {delete command} { + catch {delete} msg + set msg + } {wrong # args: should be "::struct::list::Ldelete var item"} + + test delete-1.1 {delete command} { + catch {delete x} msg + set msg + } {wrong # args: should be "::struct::list::Ldelete var item"} + + test delete-1.2 {delete command} { + set l {} + delete l x + set l + } {} + + test delete-1.3 {delete command} { + set l {a x b} + delete l x + set l + } {a b} + + test delete-1.4 {delete command} { + set l {x a b} + delete l x + set l + } {a b} + + test delete-1.5 {delete command} { + set l {a b x} + delete l x + set l + } {a b} + + test delete-1.6 {delete command} { + set l {a b} + delete l x + set l + } {a b} + + catch { unset l } + #---------------------------------------------------------------------- + + interp alias {} dbjoin {} ::struct::list::list dbJoin + interp alias {} dbjoink {} ::struct::list::list dbJoinKeyed + + #---------------------------------------------------------------------- + # Input data sets ... + + set empty {} + set table_as [list \ + {0 foo} \ + {1 snarf} \ + {2 blue} \ + ] + set table_am [list \ + {0 foo} \ + {0 bar} \ + {1 snarf} \ + {1 rim} \ + {2 blue} \ + {2 dog} \ + ] + set table_bs [list \ + {0 bagel} \ + {1 snatz} \ + {3 driver} \ + ] + set table_bm [list \ + {0 bagel} \ + {0 loaf} \ + {1 snatz} \ + {1 grid} \ + {3 driver} \ + {3 tcl} \ + ] + set table_cs [list \ + {0 smurf} \ + {3 bird} \ + {4 galapagos} \ + ] + set table_cm [list \ + {0 smurf} \ + {0 blt} \ + {3 bird} \ + {3 itcl} \ + {4 galapagos} \ + {4 tk} \ + ] + + #---------------------------------------------------------------------- + # Result data sets ... + + set nyi __not_yet_written__ + + set ijss [list \ + [list 0 foo 0 bagel] \ + [list 1 snarf 1 snatz] \ + ] + set ijsm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + ] + set ijms [list \ + [list 0 foo 0 bagel] \ + [list 0 bar 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 1 rim 1 snatz] \ + ] + set ijmm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 0 bar 0 bagel] \ + [list 0 bar 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 1 rim 1 snatz] \ + [list 1 rim 1 grid] \ + ] + + set ljss [list \ + [list 0 foo 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 2 blue {} {}] \ + ] + set ljsm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 2 blue {} {}] \ + ] + set ljms [list \ + [list 0 foo 0 bagel] \ + [list 0 bar 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 1 rim 1 snatz] \ + [list 2 blue {} {}] \ + [list 2 dog {} {}] \ + ] + set ljmm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 0 bar 0 bagel] \ + [list 0 bar 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 1 rim 1 snatz] \ + [list 1 rim 1 grid] \ + [list 2 blue {} {}] \ + [list 2 dog {} {}] \ + ] + + set rjss [list \ + [list 0 foo 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list {} {} 3 driver] \ + ] + set rjsm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list {} {} 3 driver] \ + [list {} {} 3 tcl] \ + ] + set rjms [list \ + [list 0 foo 0 bagel] \ + [list 0 bar 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 1 rim 1 snatz] \ + [list {} {} 3 driver] \ + ] + set rjmm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 0 bar 0 bagel] \ + [list 0 bar 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 1 rim 1 snatz] \ + [list 1 rim 1 grid] \ + [list {} {} 3 driver] \ + [list {} {} 3 tcl] \ + ] + + set fjss [list \ + [list 0 foo 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 2 blue {} {}] \ + [list {} {} 3 driver] \ + ] + set fjsm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 2 blue {} {}] \ + [list {} {} 3 driver] \ + [list {} {} 3 tcl] \ + ] + set fjms [list \ + [list 0 foo 0 bagel] \ + [list 0 bar 0 bagel] \ + [list 1 snarf 1 snatz] \ + [list 1 rim 1 snatz] \ + [list 2 blue {} {}] \ + [list 2 dog {} {}] \ + [list {} {} 3 driver] \ + ] + set fjmm [list \ + [list 0 foo 0 bagel] \ + [list 0 foo 0 loaf] \ + [list 0 bar 0 bagel] \ + [list 0 bar 0 loaf] \ + [list 1 snarf 1 snatz] \ + [list 1 snarf 1 grid] \ + [list 1 rim 1 snatz] \ + [list 1 rim 1 grid] \ + [list 2 blue {} {}] \ + [list 2 dog {} {}] \ + [list {} {} 3 driver] \ + [list {} {} 3 tcl] \ + ] + + set ijmmm { + {0 bar 0 bagel 0 blt} + {0 bar 0 bagel 0 smurf} + {0 bar 0 loaf 0 blt} + {0 bar 0 loaf 0 smurf} + {0 foo 0 bagel 0 blt} + {0 foo 0 bagel 0 smurf} + {0 foo 0 loaf 0 blt} + {0 foo 0 loaf 0 smurf} + } + set ljmmm { + {0 bar 0 bagel 0 blt} + {0 bar 0 bagel 0 smurf} + {0 bar 0 loaf 0 blt} + {0 bar 0 loaf 0 smurf} + {0 foo 0 bagel 0 blt} + {0 foo 0 bagel 0 smurf} + {0 foo 0 loaf 0 blt} + {0 foo 0 loaf 0 smurf} + {1 rim 1 grid {} {}} + {1 rim 1 snatz {} {}} + {1 snarf 1 grid {} {}} + {1 snarf 1 snatz {} {}} + {2 blue {} {} {} {}} + {2 dog {} {} {} {}} + } + set rjmmm { + {0 bar 0 bagel 0 blt} + {0 bar 0 bagel 0 smurf} + {0 bar 0 loaf 0 blt} + {0 bar 0 loaf 0 smurf} + {0 foo 0 bagel 0 blt} + {0 foo 0 bagel 0 smurf} + {0 foo 0 loaf 0 blt} + {0 foo 0 loaf 0 smurf} + {{} {} 3 driver 3 bird} + {{} {} 3 driver 3 itcl} + {{} {} 3 tcl 3 bird} + {{} {} 3 tcl 3 itcl} + {{} {} {} {} 4 galapagos} + {{} {} {} {} 4 tk} + } + set fjmmm { + {0 bar 0 bagel 0 blt} + {0 bar 0 bagel 0 smurf} + {0 bar 0 loaf 0 blt} + {0 bar 0 loaf 0 smurf} + {0 foo 0 bagel 0 blt} + {0 foo 0 bagel 0 smurf} + {0 foo 0 loaf 0 blt} + {0 foo 0 loaf 0 smurf} + {1 rim 1 grid {} {}} + {1 rim 1 snatz {} {}} + {1 snarf 1 grid {} {}} + {1 snarf 1 snatz {} {}} + {2 blue {} {} {} {}} + {2 dog {} {} {} {}} + {{} {} 3 driver 3 bird} + {{} {} 3 driver 3 itcl} + {{} {} 3 tcl 3 bird} + {{} {} 3 tcl 3 itcl} + {{} {} {} {} 4 galapagos} + {{} {} {} {} 4 tk} + } + + #---------------------------------------------------------------------- + # Helper, translation to keyed format. + + proc keyed {table} { + # Get the key out of the row, hardwired to column 0 + set res [list] + foreach row $table {lappend res [list [lindex $row 0] $row]} + return $res + } + + #---------------------------------------------------------------------- + # I. One table joins + + set n 0 ; # Counter for test cases + foreach {jtype inout} { + -inner empty -inner table_as -inner table_am + -left empty -left table_as -left table_am + -right empty -right table_as -right table_am + -full empty -full table_as -full table_am + } { + test dbjoin-1.$n "1-table join $jtype $inout" { + dbjoin $jtype 0 [set $inout] + } [set $inout] ; # {} + + test dbjoinKeyed-1.$n "1-table join $jtype $inout" { + dbjoink $jtype [keyed [set $inout]] + } [set $inout] ; # {} + + incr n + } + + #---------------------------------------------------------------------- + # II. Two table joins + + set n 0 ; # Counter for test cases + foreach {jtype left right result} { + -inner empty empty empty + -inner empty table_bs empty + -inner table_as empty empty + -inner table_as table_bs ijss + -inner table_as table_bm ijsm + -inner table_am table_bs ijms + -inner table_am table_bm ijmm + + -left empty empty empty + -left empty table_bs empty + -left table_as empty table_as + -left table_as table_bs ljss + -left table_as table_bm ljsm + -left table_am table_bs ljms + -left table_am table_bm ljmm + + -right empty empty empty + -right empty table_bs table_bs + -right table_as empty empty + -right table_as table_bs rjss + -right table_as table_bm rjsm + -right table_am table_bs rjms + -right table_am table_bm rjmm + + -full empty empty empty + -full empty table_bs table_bs + -full table_as empty table_as + -full table_as table_bs fjss + -full table_as table_bm fjsm + -full table_am table_bs fjms + -full table_am table_bm fjmm + } { + test dbjoin-2.$n "2-table join $jtype ($left $right) = $result" { + lsort [dbjoin $jtype 0 [set $left] 0 [set $right]] + } [lsort [set $result]] + + test dbjoinKeyed-2.$n "2-table join $jtype ($left $right) = $result" { + lsort [dbjoink $jtype [keyed [set $left]] [keyed [set $right]]] + } [lsort [set $result]] + + incr n + } + + #---------------------------------------------------------------------- + # III. Three table joins + + set n 0 ; # Counter for test cases + foreach {jtype left middle right result} { + -inner table_am table_bm table_cm ijmmm + -left table_am table_bm table_cm ljmmm + -right table_am table_bm table_cm rjmmm + -full table_am table_bm table_cm fjmmm + } { + test dbjoin-3.$n "3-table join $jtype ($left $middle $right) = $result" { + lsort [dbjoin $jtype 0 [set $left] 0 [set $middle] 0 [set $right]] + } [lsort [set $result]] + + test dbjoinKeyed-3.$n "3-table join $jtype ($left $middle $right) = $result" { + lsort [dbjoink $jtype [keyed [set $left]] [keyed [set $middle]] [keyed [set $right]]] + } [lsort [set $result]] + + incr n + } + + #---------------------------------------------------------------------- + + interp alias {} swap {} ::struct::list::list swap + + foreach {n list i j err res} { + 0 {} 0 0 1 {list index out of range} + 1 {} 3 4 1 {list index out of range} + 2 {a b c d e} -1 0 1 {list index out of range} + 3 {a b c d e} 0 -1 1 {list index out of range} + 4 {a b c d e} 6 0 1 {list index out of range} + 5 {a b c d e} 0 6 1 {list index out of range} + 6 {a b c d e} 0 0 0 {a b c d e} + 7 {a b c d e} 0 1 0 {b a c d e} + 8 {a b c d e} 1 0 0 {b a c d e} + 9 {a b c d e} 0 4 0 {e b c d a} + 10 {a b c d e} 4 0 0 {e b c d a} + 11 {a b c d e} 2 4 0 {a b e d c} + 12 {a b c d e} 4 2 0 {a b e d c} + 13 {a b c d e} 1 3 0 {a d c b e} + 14 {a b c d e} 3 1 0 {a d c b e} + } { + if {$err} { + test swap-1.$n {swap command error} { + set l $list + catch {swap l $i $j} msg + set msg + } $res ; # {} + } else { + test swap-1.$n {swap command} { + set l $list + swap l $i $j + } $res ; # {} + } + } + + + #---------------------------------------------------------------------- + + interp alias {} firstperm {} ::struct::list::list firstperm + interp alias {} nextperm {} ::struct::list::list nextperm + interp alias {} foreachperm {} ::struct::list::list foreachperm + interp alias {} permutations {} ::struct::list::list permutations + + test permutations-0.0 {permutations command, single element list} { + permutations a + } a + + + array set ps { + {Tom Dick Harry Bob} { + 0 {Bob Dick Harry Tom} {Tom Harry Bob Dick} + { + {Bob Dick Harry Tom} {Bob Dick Tom Harry} + {Bob Harry Dick Tom} {Bob Harry Tom Dick} + {Bob Tom Dick Harry} {Bob Tom Harry Dick} + {Dick Bob Harry Tom} {Dick Bob Tom Harry} + {Dick Harry Bob Tom} {Dick Harry Tom Bob} + {Dick Tom Bob Harry} {Dick Tom Harry Bob} + {Harry Bob Dick Tom} {Harry Bob Tom Dick} + {Harry Dick Bob Tom} {Harry Dick Tom Bob} + {Harry Tom Bob Dick} {Harry Tom Dick Bob} + {Tom Bob Dick Harry} {Tom Bob Harry Dick} + {Tom Dick Bob Harry} {Tom Dick Harry Bob} + {Tom Harry Bob Dick} {Tom Harry Dick Bob} + } + } + {3 2 1 4} { + 1 {1 2 3 4} {3 2 4 1} + { + {1 2 3 4} {1 2 4 3} {1 3 2 4} {1 3 4 2} + {1 4 2 3} {1 4 3 2} {2 1 3 4} {2 1 4 3} + {2 3 1 4} {2 3 4 1} {2 4 1 3} {2 4 3 1} + {3 1 2 4} {3 1 4 2} {3 2 1 4} {3 2 4 1} + {3 4 1 2} {3 4 2 1} {4 1 2 3} {4 1 3 2} + {4 2 1 3} {4 2 3 1} {4 3 1 2} {4 3 2 1} + } + } + } + + foreach k [array names ps] { + foreach {n firstp nextp allp} $ps($k) break + + test firstperm-1.$n {firstperm command} { + firstperm $k + } $firstp ; # {} + + test nextperm-1.$n {nextperm command} { + nextperm $k + } $nextp ; # {} + + # Note: The lrange below is necessary a trick/hack to kill the + # existing string representation of allp, and get a pure list out + # of it. Otherwise the string based comparison of test will fail, + # seeing different string reps of the same list. + + test permutations-1.$n {permutations command} { + permutations $k + } [lrange $allp 0 end] ; # {} + + test foreachperm-1.$n {foreachperm command} { + set res {} + foreachperm x $k {lappend res $x} + set res + } [lrange $allp 0 end] ; # {} + } + + test nextperm-2.0 {bug 3593689, busyloop} { + nextperm {1 10 9 8 7 6 5 4 3 2} + } {1 2 10 3 4 5 6 7 8 9} + + #---------------------------------------------------------------------- + + interp alias {} shuffle {} ::struct::list::list shuffle + + test shuffle-1.0 {} -body { + shuffle + } -returnCodes error -result {wrong # args: should be "::struct::list::Lshuffle list"} + + test shuffle-2.0 {shuffle nothing} -body { + shuffle {} + } -result {} + + test shuffle-2.1 {shuffle single} -body { + shuffle {a} + } -result {a} + + foreach {k n data} { + 1 2 {a b} + 2 4 {c d b a} + 3 9 {0 1 2 3 4 5 6 7 8} + 4 15 {a b c d e f 8 6 4 2 0 1 3 5 7} + } { + test shuffle-2.2.$k "shuffle $n" -body { + lsort [shuffle $data] + } -result [lsort $data] + } +} + +package provide struct::list::test 1.8.5 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/map.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/map.tcl new file mode 100644 index 00000000..bd31a158 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/map.tcl @@ -0,0 +1,104 @@ +# map.tcl -- +# Copyright (c) 2009-2019 Andreas Kupries +# +# Object wrapper around array/dict. Useful as key/value store in +# larger systems. +# +# Examples: +# - configuration mgmt in doctools v2 import/export managers +# - pt import/export managers +# +# Each object manages a key/value map. + +# ### ### ### ######### ######### ######### +## Requisites + +package require Tcl 8.5 9 +package require snit + +# ### ### ### ######### ######### ######### +## API + +# ATTENTION: +## +# From an API point of view the code below is equivalent to the much +# shorter `snit::type struct::map { ... }`. +# +# Then why the more complex form ? +# +# When snit compiles the class to Tcl code, and later on when methods +# are executed it will happen in the `struct` namespace. The moment +# this package is used together with `struct::set` all unqualified +# `set` statements will go bonkers, eiter in snit, or, here, in method +# `set`, because they get resolved to the `struct::set` dispatcher +# instead of `::set`. Moving the implementation a level deeper makes +# the `struct::map` namespace the context, with no conflict. + +# Future / TODO: Convert all the OO stuff here over to TclOO, as much +# as possible (snit configure/cget support is currently still better, +# ditto hierarchical methods). + +namespace eval ::struct {} + +proc ::struct::map {args} { + uplevel 1 [linsert $args 0 struct::map::I] +} + +snit::type ::struct::map::I { + + # ### ### ### ######### ######### ######### + ## Options :: None + + # ### ### ### ######### ######### ######### + ## Creating, destruction + + # Default constructor. + # Default destructor. + + # ### ### ### ######### ######### ######### + ## Public methods. Reading and writing the map. + + method names {} { + return [array names mymap] + } + + method get {} { + return [array get mymap] + } + + method set {name {value {}}} { + # 7 instead of 3 in the condition below, because of the 4 + # implicit arguments snit is providing to each method. + if {[llength [info level 0]] == 7} { + ::set mymap($name) $value + } elseif {![info exists mymap($name)]} { + return -code error "can't read \"$name\": no such variable" + } + return $mymap($name) + } + + method unset {args} { + if {![llength $args]} { lappend args * } + foreach pattern $args { + array unset mymap $pattern + } + return + } + + # ### ### ### ######### ######### ######### + ## Internal methods :: None. + + # ### ### ### ######### ######### ######### + ## State :: Map data, Tcl array + + variable mymap -array {} + + ## + # ### ### ### ######### ######### ######### +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide struct::map 1.1 +return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/matrix.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/matrix.tcl new file mode 100644 index 00000000..a8284015 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/matrix.tcl @@ -0,0 +1,2806 @@ +# matrix.tcl -- +# +# Implementation of a matrix data structure for Tcl. +# +# Copyright (c) 2001-2013,2019,2022 by Andreas Kupries +# +# Heapsort code Copyright (c) 2003 by Edwin A. Suominen , +# based on concepts in "Introduction to Algorithms" by Thomas H. Cormen et al. +# +# 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 9 +package require textutil::wcswidth ;# TermWidth, for _columnwidth and related places + +namespace eval ::struct {} + +namespace eval ::struct::matrix { + # Data storage in the matrix module + # ------------------------------- + # + # One namespace per object, containing + # + # - Two scalar variables containing the current number of rows and columns. + # - Four array variables containing the array data, the caches for + # row heights and column widths and the information about linked arrays. + # + # The variables are + # - columns #columns in data + # - rows #rows in data + # - data cell contents + # - colw cache of column widths + # - rowh cache of row heights + # - link information about linked arrays + # - lock boolean flag to disable MatTraceIn while in MatTraceOut [#532783] + # - unset string used to convey information about 'unset' traces from MatTraceIn to MatTraceOut. + + # counter is used to give a unique name for unnamed matrices + variable counter 0 + + # Only export one command, the one used to instantiate a new matrix + namespace export matrix +} + +# ::struct::matrix::matrix -- +# +# Create a new matrix with a given name; if no name is given, use +# matrixX, where X is a number. +# +# Arguments: +# name Optional name of the matrix; if null or not given, generate one. +# +# Results: +# name Name of the matrix created + +proc ::struct::matrix::matrix {args} { + variable counter + + set src {} + set srctype {} + + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "matrix${counter}" + } + 2 { + # Standard call. New empty matrix. + set name [lindex $args 0] + } + 4 { + # Copy construction. + foreach {name as src} $args break + switch -exact -- $as { + = - := - as { + set srctype matrix + } + deserialize { + set srctype serial + } + default { + return -code error \ + "wrong # args: should be \"matrix ?name ?=|:=|as|deserialize source??\"" + } + } + } + default { + # Error. + return -code error \ + "wrong # args: should be \"matrix ?name ?=|:=|as|deserialize source??\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + set name "$ns$name" + } + + if { [llength [info commands $name]] } { + return -code error "command \"$name\" already exists, unable to create matrix" + } + + # Set up the namespace + namespace eval $name { + variable columns 0 + variable rows 0 + + variable data + variable colw + variable rowh + variable link + variable lock + variable unset + + array set data {} + array set colw {} + array set rowh {} + array set link {} + set lock 0 + set unset {} + } + + # Create the command to manipulate the matrix + interp alias {} $name {} ::struct::matrix::MatrixProc $name + + # Automatic execution of assignment if a source + # is present. + if {$src != {}} { + switch -exact -- $srctype { + matrix {_= $name $src} + serial {_deserialize $name $src} + default { + return -code error \ + "Internal error, illegal srctype \"$srctype\"" + } + } + } + return $name +} + +########################## +# Private functions follow + +# ::struct::matrix::MatrixProc -- +# +# Command that processes all matrix object commands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand to invoke. +# args Arguments for subcommand. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::MatrixProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub _$cmd + if {[llength [info commands ::struct::matrix::$sub]] == 0} { + set optlist [lsort [info commands ::struct::matrix::_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + if {[string match __* $p]} {continue} + lappend xlist [string range $p 1 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_= -- +# +# Assignment operator. Copies the source matrix into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the matrix object we are copying into. +# source Name of the matrix object providing us with the +# data to copy. +# +# Results: +# Nothing. + +proc ::struct::matrix::_= {name source} { + _deserialize $name [$source serialize] + return +} + +# ::struct::matrix::_--> -- +# +# Reverse assignment operator. Copies this matrix into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the matrix object to copy +# dest Name of the matrix object we are copying to. +# +# Results: +# Nothing. + +proc ::struct::matrix::_--> {name dest} { + $dest deserialize [_serialize $name] + return +} + +# ::struct::matrix::_add -- +# +# Command that processes all 'add' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'add' to invoke. +# args Arguments for subcommand of 'add'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_add {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name add option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __add_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__add_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_delete -- +# +# Command that processes all 'delete' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'delete' to invoke. +# args Arguments for subcommand of 'delete'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_delete {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name delete option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __delete_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__delete_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 9 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_format -- +# +# Command that processes all 'format' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'format' to invoke. +# args Arguments for subcommand of 'format'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_format {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name format option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __format_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__format_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 9 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_get -- +# +# Command that processes all 'get' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'get' to invoke. +# args Arguments for subcommand of 'get'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_get {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name get option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __get_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__get_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_insert -- +# +# Command that processes all 'insert' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'insert' to invoke. +# args Arguments for subcommand of 'insert'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_insert {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name insert option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __insert_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__insert_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 9 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_search -- +# +# Command that processes all 'search' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# args Arguments for search. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_search {name args} { + set mode exact + set nocase 0 + + while {1} { + switch -glob -- [lindex $args 0] { + -exact - -glob - -regexp { + set mode [string range [lindex $args 0] 1 end] + set args [lrange $args 1 end] + } + -nocase { + set nocase 1 + set args [lrange $args 1 end] + } + -* { + return -code error \ + "invalid option \"[lindex $args 0]\":\ + should be -nocase, -exact, -glob, or -regexp" + } + default { + break + } + } + } + + # Possible argument signatures after option processing + # + # \ | args + # --+-------------------------------------------------------- + # 2 | all pattern + # 3 | row row pattern, column col pattern + # 6 | rect ctl rtl cbr rbr pattern + # + # All range specifications are internally converted into a + # rectangle. + + switch -exact -- [llength $args] { + 2 - 3 - 6 {} + default { + return -code error \ + "wrong # args: should be\ + \"$name search ?option...? (all|row row|column col|rect c r c r) pattern\"" + } + } + + set range [lindex $args 0] + set pattern [lindex $args end] + set args [lrange $args 1 end-1] + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + + switch -exact -- $range { + all { + set ctl 0 ; set cbr $columns ; incr cbr -1 + set rtl 0 ; set rbr $rows ; incr rbr -1 + } + column { + set ctl [ChkColumnIndex $name [lindex $args 0]] + set cbr $ctl + set rtl 0 ; set rbr $rows ; incr rbr -1 + } + row { + set rtl [ChkRowIndex $name [lindex $args 0]] + set ctl 0 ; set cbr $columns ; incr cbr -1 + set rbr $rtl + } + rect { + foreach {ctl rtl cbr rbr} $args break + set ctl [ChkColumnIndex $name $ctl] + set rtl [ChkRowIndex $name $rtl] + set cbr [ChkColumnIndex $name $cbr] + set rbr [ChkRowIndex $name $rbr] + if {($ctl > $cbr) || ($rtl > $rbr)} { + return -code error "Invalid cell indices, wrong ordering" + } + } + default { + return -code error "invalid range spec \"$range\": should be all, column, row, or rect" + } + } + + if {$nocase} { + set pattern [string tolower $pattern] + } + + set matches [list] + for {set r $rtl} {$r <= $rbr} {incr r} { + for {set c $ctl} {$c <= $cbr} {incr c} { + set v $data($c,$r) + if {$nocase} { + set v [string tolower $v] + } + switch -exact -- $mode { + exact {set matched [string equal $pattern $v]} + glob {set matched [string match $pattern $v]} + regexp {set matched [regexp -- $pattern $v]} + } + if {$matched} { + lappend matches [list $c $r] + } + } + } + return $matches +} + +# ::struct::matrix::_set -- +# +# Command that processes all 'set' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'set' to invoke. +# args Arguments for subcommand of 'set'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_set {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name set option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __set_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__set_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_sort -- +# +# Command that processes all 'sort' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'sort' to invoke. +# args Arguments for subcommand of 'sort'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_sort {name cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name sort option ?arg arg ...?\"" + } + if {[string equal $cmd "rows"]} { + set code r + set byrows 1 + } elseif {[string equal $cmd "columns"]} { + set code c + set byrows 0 + } else { + return -code error \ + "bad option \"$cmd\": must be columns, or rows" + } + + set revers 0 ;# Default: -increasing + while {1} { + switch -glob -- [lindex $args 0] { + -increasing {set revers 0} + -decreasing {set revers 1} + default { + if {[llength $args] > 1} { + return -code error \ + "invalid option \"[lindex $args 0]\":\ + should be -increasing, or -decreasing" + } + break + } + } + set args [lrange $args 1 end] + } + # ASSERT: [llength $args] == 1 + + if {[llength $args] != 1} { + return -code error "wrong # args: should be \"$name sort option ?arg arg ...?\"" + } + + set key [lindex $args 0] + + if {$byrows} { + set key [ChkColumnIndex $name $key] + variable ${name}::rows + + # Adapted by EAS from BUILD-MAX-HEAP(A) of CRLS 6.3 + set heapSize $rows + } else { + set key [ChkRowIndex $name $key] + variable ${name}::columns + + # Adapted by EAS from BUILD-MAX-HEAP(A) of CRLS 6.3 + set heapSize $columns + } + + for {set i [expr {int($heapSize/2)-1}]} {$i>=0} {incr i -1} { + SortMaxHeapify $name $i $key $code $heapSize $revers + } + + # Adapted by EAS from remainder of HEAPSORT(A) of CRLS 6.4 + for {set i [expr {$heapSize-1}]} {$i>=1} {incr i -1} { + if {$byrows} { + SwapRows $name 0 $i + } else { + SwapColumns $name 0 $i + } + incr heapSize -1 + SortMaxHeapify $name 0 $key $code $heapSize $revers + } + return +} + +# ::struct::matrix::_swap -- +# +# Command that processes all 'swap' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'swap' to invoke. +# args Arguments for subcommand of 'swap'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_swap {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name swap option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __swap_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__swap_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 7 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::__add_column -- +# +# Extends the matrix by one column and then acts like +# "setcolumn" (see below) on this new column if there were +# "values" supplied. Without "values" the new cells will be set +# to the empty string. The new column is appended immediately +# behind the last existing column. +# +# Arguments: +# name Name of the matrix object. +# values Optional values to set into the new row. +# +# Results: +# None. + +proc ::struct::matrix::__add_column {name {values {}}} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::rowh + + if {[set l [llength $values]] < $rows} { + # Missing values. Fill up with empty strings + + for {} {$l < $rows} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $rows} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$rows - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - The new column is not added to the width cache, the other + # columns are not touched, the cache therefore unchanged. + # - The rows are either removed from the height cache or left + # unchanged, depending on the contents set into the cell. + + set r 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset rowh($r)} + } ; # {else leave the row unchanged} + set data($columns,$r) $v + incr r + } + incr columns + return +} + +# ::struct::matrix::__add_row -- +# +# Extends the matrix by one row and then acts like "setrow" (see +# below) on this new row if there were "values" +# supplied. Without "values" the new cells will be set to the +# empty string. The new row is appended immediately behind the +# last existing row. +# +# Arguments: +# name Name of the matrix object. +# values Optional values to set into the new row. +# +# Results: +# None. + +proc ::struct::matrix::__add_row {name {values {}}} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::colw + + if {[set l [llength $values]] < $columns} { + # Missing values. Fill up with empty strings + + for {} {$l < $columns} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $columns} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$columns - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - The new row is not added to the height cache, the other + # rows are not touched, the cache therefore unchanged. + # - The columns are either removed from the width cache or left + # unchanged, depending on the contents set into the cell. + + set c 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset colw($c)} + } ; # {else leave the row unchanged} + set data($c,$rows) $v + incr c + } + incr rows + return +} + +# ::struct::matrix::__add_columns -- +# +# Extends the matrix by "n" columns. The new cells will be set +# to the empty string. The new columns are appended immediately +# behind the last existing column. A value of "n" equal to or +# smaller than 0 is not allowed. +# +# Arguments: +# name Name of the matrix object. +# n The number of new columns to create. +# +# Results: +# None. + +proc ::struct::matrix::__add_columns {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + AddColumns $name $n + return +} + +proc ::struct::matrix::AddColumns {name n} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + + # The new values set into the cell is always the empty + # string. These have a length and height of 0, i.e. the don't + # influence cached widths and heights as they are at least that + # big. IOW there is no need to touch and change the width and + # height caches. + + while {$n > 0} { + for {set r 0} {$r < $rows} {incr r} { + set data($columns,$r) "" + } + incr columns + incr n -1 + } + + return +} + +# ::struct::matrix::__add_rows -- +# +# Extends the matrix by "n" rows. The new cells will be set to +# the empty string. The new rows are appended immediately behind +# the last existing row. A value of "n" equal to or smaller than +# 0 is not allowed. +# +# Arguments: +# name Name of the matrix object. +# n The number of new rows to create. +# +# Results: +# None. + +proc ::struct::matrix::__add_rows {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + AddRows $name $n + return +} + +proc ::struct::matrix::AddRows {name n} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + + # The new values set into the cell is always the empty + # string. These have a length and height of 0, i.e. the don't + # influence cached widths and heights as they are at least that + # big. IOW there is no need to touch and change the width and + # height caches. + + while {$n > 0} { + for {set c 0} {$c < $columns} {incr c} { + set data($c,$rows) "" + } + incr rows + incr n -1 + } + return +} + +# ::struct::matrix::_cells -- +# +# Returns the number of cells currently managed by the +# matrix. This is the product of "rows" and "columns". +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# The number of cells in the matrix. + +proc ::struct::matrix::_cells {name} { + variable ${name}::rows + variable ${name}::columns + return [expr {$rows * $columns}] +} + +# ::struct::matrix::_cellsize -- +# +# Returns the length of the string representation of the value +# currently contained in the addressed cell. +# +# Arguments: +# name Name of the matrix object. +# column Column index of the cell to query +# row Row index of the cell to query +# +# Results: +# The number of cells in the matrix. + +proc ::struct::matrix::_cellsize {name column row} { + set column [ChkColumnIndex $name $column] + set row [ChkRowIndex $name $row] + + variable ${name}::data + return [string length $data($column,$row)] +} + +# ::struct::matrix::_columns -- +# +# Returns the number of columns currently managed by the +# matrix. +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# The number of columns in the matrix. + +proc ::struct::matrix::_columns {name} { + variable ${name}::columns + return $columns +} + +# ::struct::matrix::_columnwidth -- +# +# Returns the length of the longest string representation of all +# the values currently contained in the cells of the addressed +# column if these are all spanning only one line. For cell +# values spanning multiple lines the length of their longest +# line goes into the computation. +# +# Arguments: +# name Name of the matrix object. +# column The index of the column whose width is asked for. +# +# Results: +# See description. + +proc ::struct::matrix::_columnwidth {name column} { + set column [ChkColumnIndex $name $column] + + variable ${name}::colw + + if {![info exists colw($column)]} { + variable ${name}::rows + variable ${name}::data + + set width 0 + for {set r 0} {$r < $rows} {incr r} { + foreach line [split $data($column,$r) \n] { + set len [TermWidth $line] + if {$len > $width} { + set width $len + } + } + } + + set colw($column) $width + } + + return $colw($column) +} + +# ::struct::matrix::__delete_column -- +# +# Deletes the specified column from the matrix and shifts all +# columns with higher indices one index down. +# +# Arguments: +# name Name of the matrix. +# column The index of the column to delete. +# +# Results: +# None. + +proc ::struct::matrix::__delete_column {name column} { + set column [ChkColumnIndex $name $column] + + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher columns down and then delete the + # superfluous data in the old last column. Move the data in the + # width cache too, take partial fill into account there too. + # Invalidate the height cache for all rows. + + for {set r 0} {$r < $rows} {incr r} { + for {set c $column; set cn [expr {$c + 1}]} {$cn < $columns} {incr c ; incr cn} { + set data($c,$r) $data($cn,$r) + if {[info exists colw($cn)]} { + set colw($c) $colw($cn) + unset colw($cn) + } + } + unset data($c,$r) + catch {unset rowh($r)} + } + incr columns -1 + return +} + +# ::struct::matrix::__delete_columns -- +# +# Shrink the matrix by "n" columns (from the right). +# A value of "n" equal to or smaller than 0 is not +# allowed, nor is "n" allowed to be greater than the +# number of columns in the matrix. +# +# Arguments: +# name Name of the matrix object. +# n The number of columns to remove. +# +# Results: +# None. + +proc ::struct::matrix::__delete_columns {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + + variable ${name}::columns + + if {$n > $columns} { + return -code error "A value of n > #columns is not allowed" + } + + DeleteColumns $name $n + return +} + +# ::struct::matrix::__delete_row -- +# +# Deletes the specified row from the matrix and shifts all +# row with higher indices one index down. +# +# Arguments: +# name Name of the matrix. +# row The index of the row to delete. +# +# Results: +# None. + +proc ::struct::matrix::__delete_row {name row} { + set row [ChkRowIndex $name $row] + + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher rows down and then delete the + # superfluous data in the old last row. Move the data in the + # height cache too, take partial fill into account there too. + # Invalidate the width cache for all columns. + + for {set c 0} {$c < $columns} {incr c} { + for {set r $row; set rn [expr {$r + 1}]} {$rn < $rows} {incr r ; incr rn} { + set data($c,$r) $data($c,$rn) + if {[info exists rowh($rn)]} { + set rowh($r) $rowh($rn) + unset rowh($rn) + } + } + unset data($c,$r) + catch {unset colw($c)} + } + incr rows -1 + return +} + +# ::struct::matrix::__delete_rows -- +# +# Shrink the matrix by "n" rows (from the bottom). +# A value of "n" equal to or smaller than 0 is not +# allowed, nor is "n" allowed to be greater than the +# number of rows in the matrix. +# +# Arguments: +# name Name of the matrix object. +# n The number of rows to remove. +# +# Results: +# None. + +proc ::struct::matrix::__delete_rows {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + + variable ${name}::rows + + if {$n > $rows} { + return -code error "A value of n > #rows is not allowed" + } + + DeleteRows $name $n + return +} + +# ::struct::matrix::_deserialize -- +# +# Assignment operator. Copies a serialization into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the matrix object we are copying into. +# serial Serialized matrix to copy from. +# +# Results: +# Nothing. + +proc ::struct::matrix::_deserialize {name serial} { + # As we destroy the original matrix as part of + # the copying process we don't have to deal + # with issues like node names from the new matrix + # interfering with the old ... + + # I. Get the serialization of the source matrix + # and check it for validity. + + CheckSerialization $serial r c values + + # Get all the relevant data into the scope + + variable ${name}::rows + variable ${name}::columns + + # Resize the destination matrix for the new data + + if {$r > $rows} { + AddRows $name [expr {$r - $rows}] + } elseif {$r < $rows} { + DeleteRows $name [expr {$rows - $r}] + } + if {$c > $columns} { + AddColumns $name [expr {$c - $columns}] + } elseif {$c < $columns} { + DeleteColumns $name [expr {$columns - $c}] + } + + set rows $r + set columns $c + + # Copy the new data over the old information. + + set row 0 + foreach rv $values { + SetRow $name $row $rv + incr row + } + while {$row < $rows} { + # Fill with empty rows if there are not enough. + SetRow $name $row {} + incr row + } + return +} + +# ::struct::matrix::_destroy -- +# +# Destroy a matrix, including its associated command and data storage. +# +# Arguments: +# name Name of the matrix to destroy. +# +# Results: +# None. + +proc ::struct::matrix::_destroy {name} { + variable ${name}::link + + # Unlink all existing arrays before destroying the object so that + # we don't leave dangling references / traces. + + foreach avar [array names link] { + _unlink $name $avar + } + + namespace delete $name + interp alias {} $name {} +} + +# ::struct::matrix::__format_2string -- +# +# Formats the matrix using the specified report object and +# returns the string containing the result of this +# operation. The report has to support the "printmatrix" method. +# +# Arguments: +# name Name of the matrix. +# report Name of the report object specifying the formatting. +# +# Results: +# A string containing the formatting result. + +proc ::struct::matrix::__format_2string {name {report {}}} { + if {$report == {}} { + # Use an internal hardwired simple report to format the matrix. + # 1. Go through all columns and compute the column widths. + # 2. Then iterate through all rows and dump then into a + # string, formatted to the number of characters per columns + + array set cw {} + set cols [_columns $name] + for {set c 0} {$c < $cols} {incr c} { + set cw($c) [_columnwidth $name $c] + } + + set result [list] + set n [_rows $name] + for {set r 0} {$r < $n} {incr r} { + set rh [_rowheight $name $r] + if {$rh < 2} { + # Simple row. + set line [list] + for {set c 0} {$c < $cols} {incr c} { + set val [__get_cell $name $c $r] + lappend line "$val[string repeat " " [expr {$cw($c)-[TermWidth $val]}]]" + } + lappend result [join $line " "] + } else { + # Complex row, multiple passes + for {set h 0} {$h < $rh} {incr h} { + set line [list] + for {set c 0} {$c < $cols} {incr c} { + set val [lindex [split [__get_cell $name $c $r] \n] $h] + lappend line "$val[string repeat " " [expr {$cw($c)-[TermWidth $val]}]]" + } + lappend result [join $line " "] + } + } + } + return [join $result \n] + } else { + return [$report printmatrix $name] + } +} + +# ::struct::matrix::__format_2chan -- +# +# Formats the matrix using the specified report object and +# writes the string containing the result of this operation into +# the channel. The report has to support the +# "printmatrix2channel" method. +# +# Arguments: +# name Name of the matrix. +# report Name of the report object specifying the formatting. +# chan Handle of the channel to write to. +# +# Results: +# None. + +proc ::struct::matrix::__format_2chan {name {report {}} {chan stdout}} { + if {$report == {}} { + # Use an internal hardwired simple report to format the matrix. + # We delegate this to the string formatter and print its result. + puts -nonewline $chan [__format_2string $name] + } else { + $report printmatrix2channel $name $chan + } + return +} + +# ::struct::matrix::__get_cell -- +# +# Returns the value currently contained in the cell identified +# by row and column index. +# +# Arguments: +# name Name of the matrix. +# column Column index of the addressed cell. +# row Row index of the addressed cell. +# +# Results: +# value Value currently stored in the addressed cell. + +proc ::struct::matrix::__get_cell {name column row} { + set column [ChkColumnIndex $name $column] + set row [ChkRowIndex $name $row] + + variable ${name}::data + return $data($column,$row) +} + +# ::struct::matrix::__get_column -- +# +# Returns a list containing the values from all cells in the +# column identified by the index. The contents of the cell in +# row 0 are stored as the first element of this list. +# +# Arguments: +# name Name of the matrix. +# column Column index of the addressed cell. +# +# Results: +# List of values stored in the addressed row. + +proc ::struct::matrix::__get_column {name column} { + set column [ChkColumnIndex $name $column] + return [GetColumn $name $column] +} + +proc ::struct::matrix::GetColumn {name column} { + variable ${name}::data + variable ${name}::rows + + set result [list] + for {set r 0} {$r < $rows} {incr r} { + lappend result $data($column,$r) + } + return $result +} + +# ::struct::matrix::__get_rect -- +# +# Returns a list of lists of cell values. The values stored in +# the result come from the submatrix whose top-left and +# bottom-right cells are specified by "column_tl", "row_tl" and +# "column_br", "row_br" resp. Note that the following equations +# have to be true: column_tl <= column_br and row_tl <= row_br. +# The result is organized as follows: The outer list is the list +# of rows, its elements are lists representing a single row. The +# row with the smallest index is the first element of the outer +# list. The elements of the row lists represent the selected +# cell values. The cell with the smallest index is the first +# element in each row list. +# +# Arguments: +# name Name of the matrix. +# column_tl Column index of the top-left cell of the area. +# row_tl Row index of the top-left cell of the the area +# column_br Column index of the bottom-right cell of the area. +# row_br Row index of the bottom-right cell of the the area +# +# Results: +# List of a list of values stored in the addressed area. + +proc ::struct::matrix::__get_rect {name column_tl row_tl column_br row_br} { + set column_tl [ChkColumnIndex $name $column_tl] + set row_tl [ChkRowIndex $name $row_tl] + set column_br [ChkColumnIndex $name $column_br] + set row_br [ChkRowIndex $name $row_br] + + if { + ($column_tl > $column_br) || + ($row_tl > $row_br) + } { + return -code error "Invalid cell indices, wrong ordering" + } + return [GetRect $name $column_tl $row_tl $column_br $row_br] +} + +proc ::struct::matrix::GetRect {name column_tl row_tl column_br row_br} { + variable ${name}::data + set result [list] + + for {set r $row_tl} {$r <= $row_br} {incr r} { + set row [list] + for {set c $column_tl} {$c <= $column_br} {incr c} { + lappend row $data($c,$r) + } + lappend result $row + } + + return $result +} + +# ::struct::matrix::__get_row -- +# +# Returns a list containing the values from all cells in the +# row identified by the index. The contents of the cell in +# column 0 are stored as the first element of this list. +# +# Arguments: +# name Name of the matrix. +# row Row index of the addressed cell. +# +# Results: +# List of values stored in the addressed row. + +proc ::struct::matrix::__get_row {name row} { + set row [ChkRowIndex $name $row] + return [GetRow $name $row] +} + +proc ::struct::matrix::GetRow {name row} { + variable ${name}::data + variable ${name}::columns + + set result [list] + for {set c 0} {$c < $columns} {incr c} { + lappend result $data($c,$row) + } + return $result +} + +# ::struct::matrix::__insert_column -- +# +# Extends the matrix by one column and then acts like +# "setcolumn" (see below) on this new column if there were +# "values" supplied. Without "values" the new cells will be set +# to the empty string. The new column is inserted just before +# the column specified by the given index. This means, if +# "column" is less than or equal to zero, then the new column is +# inserted at the beginning of the matrix, before the first +# column. If "column" has the value "Bend", or if it is greater +# than or equal to the number of columns in the matrix, then the +# new column is appended to the matrix, behind the last +# column. The old column at the chosen index and all columns +# with higher indices are shifted one index upward. +# +# Arguments: +# name Name of the matrix. +# column Index of the column where to insert. +# values Optional values to set the cells to. +# +# Results: +# None. + +proc ::struct::matrix::__insert_column {name column {values {}}} { + # Allow both negative and too big indices. + set column [ChkColumnIndexAll $name $column] + + variable ${name}::columns + + if {$column > $columns} { + # Same as 'addcolumn' + __add_column $name $values + return + } + + variable ${name}::data + variable ${name}::rows + variable ${name}::rowh + variable ${name}::colw + + set firstcol $column + if {$firstcol < 0} { + set firstcol 0 + } + + if {[set l [llength $values]] < $rows} { + # Missing values. Fill up with empty strings + + for {} {$l < $rows} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $rows} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$rows - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + # Invalidate all rows, move all columns + + # Move all data from the higher columns one up and then insert the + # new data into the freed space. Move the data in the + # width cache too, take partial fill into account there too. + # Invalidate the height cache for all rows. + + for {set r 0} {$r < $rows} {incr r} { + for {set cn $columns ; set c [expr {$cn - 1}]} {$c >= $firstcol} {incr c -1 ; incr cn -1} { + set data($cn,$r) $data($c,$r) + if {[info exists colw($c)]} { + set colw($cn) $colw($c) + unset colw($c) + } + } + set data($firstcol,$r) [lindex $values $r] + catch {unset rowh($r)} + } + incr columns + return +} + +# ::struct::matrix::__insert_row -- +# +# Extends the matrix by one row and then acts like "setrow" (see +# below) on this new row if there were "values" +# supplied. Without "values" the new cells will be set to the +# empty string. The new row is inserted just before the row +# specified by the given index. This means, if "row" is less +# than or equal to zero, then the new row is inserted at the +# beginning of the matrix, before the first row. If "row" has +# the value "end", or if it is greater than or equal to the +# number of rows in the matrix, then the new row is appended to +# the matrix, behind the last row. The old row at that index and +# all rows with higher indices are shifted one index upward. +# +# Arguments: +# name Name of the matrix. +# row Index of the row where to insert. +# values Optional values to set the cells to. +# +# Results: +# None. + +proc ::struct::matrix::__insert_row {name row {values {}}} { + # Allow both negative and too big indices. + set row [ChkRowIndexAll $name $row] + + variable ${name}::rows + + if {$row > $rows} { + # Same as 'addrow' + __add_row $name $values + return + } + + variable ${name}::data + variable ${name}::columns + variable ${name}::rowh + variable ${name}::colw + + set firstrow $row + if {$firstrow < 0} { + set firstrow 0 + } + + if {[set l [llength $values]] < $columns} { + # Missing values. Fill up with empty strings + + for {} {$l < $columns} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $columns} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$columns - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + # Invalidate all columns, move all rows + + # Move all data from the higher rows one up and then insert the + # new data into the freed space. Move the data in the + # height cache too, take partial fill into account there too. + # Invalidate the width cache for all columns. + + for {set c 0} {$c < $columns} {incr c} { + for {set rn $rows ; set r [expr {$rn - 1}]} {$r >= $firstrow} {incr r -1 ; incr rn -1} { + set data($c,$rn) $data($c,$r) + if {[info exists rowh($r)]} { + set rowh($rn) $rowh($r) + unset rowh($r) + } + } + set data($c,$firstrow) [lindex $values $c] + catch {unset colw($c)} + } + incr rows + return +} + +# ::struct::matrix::_link -- +# +# Links the matrix to the specified array variable. This means +# that the contents of all cells in the matrix is stored in the +# array too, with all changes to the matrix propagated there +# too. The contents of the cell "(column,row)" is stored in the +# array using the key "column,row". If the option "-transpose" +# is specified the key "row,column" will be used instead. It is +# possible to link the matrix to more than one array. Note that +# the link is bidirectional, i.e. changes to the array are +# mirrored in the matrix too. +# +# Arguments: +# name Name of the matrix object. +# option Either empty of '-transpose'. +# avar Name of the variable to link to +# +# Results: +# None + +proc ::struct::matrix::_link {name args} { + switch -exact -- [llength $args] { + 0 { + return -code error "$name: wrong # args: link ?-transpose? arrayvariable" + } + 1 { + set transpose 0 + set variable [lindex $args 0] + } + 2 { + foreach {t variable} $args break + if {[string compare $t -transpose]} { + return -code error "$name: illegal syntax: link ?-transpose? arrayvariable" + } + set transpose 1 + } + default { + return -code error "$name: wrong # args: link ?-transpose? arrayvariable" + } + } + + variable ${name}::link + + if {[info exists link($variable)]} { + return -code error "$name link: Variable \"$variable\" already linked to matrix" + } + + # Ok, a new variable we are linked to. Record this information, + # dump our current contents into the array, at last generate the + # traces actually performing the link. + + set link($variable) $transpose + + upvar #0 $variable array + variable ${name}::data + + foreach key [array names data] { + foreach {c r} [split $key ,] break + if {$transpose} { + set array($r,$c) $data($key) + } else { + set array($c,$r) $data($key) + } + } + + trace add variable array {write unset} [list ::struct::matrix::MatTraceIn $variable $name] + trace add variable data write [list ::struct::matrix::MatTraceOut $variable $name] + return +} + +# ::struct::matrix::_links -- +# +# Retrieves the names of all array variable the matrix is +# officially linked to. +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# List of variables the matrix is linked to. + +proc ::struct::matrix::_links {name} { + variable ${name}::link + return [array names link] +} + +# ::struct::matrix::_rowheight -- +# +# Returns the height of the specified row in lines. This is the +# highest number of lines spanned by a cell over all cells in +# the row. +# +# Arguments: +# name Name of the matrix +# row Index of the row queried for its height +# +# Results: +# The height of the specified row in lines. + +proc ::struct::matrix::_rowheight {name row} { + set row [ChkRowIndex $name $row] + + variable ${name}::rowh + + if {![info exists rowh($row)]} { + variable ${name}::columns + variable ${name}::data + + set height 1 + for {set c 0} {$c < $columns} {incr c} { + set cheight [llength [split $data($c,$row) \n]] + if {$cheight > $height} { + set height $cheight + } + } + + set rowh($row) $height + } + return $rowh($row) +} + +# ::struct::matrix::_rows -- +# +# Returns the number of rows currently managed by the matrix. +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# The number of rows in the matrix. + +proc ::struct::matrix::_rows {name} { + variable ${name}::rows + return $rows +} + +# ::struct::matrix::_serialize -- +# +# Serialize a matrix object (partially) into a transportable value. +# If only a rectangle is serialized the result will be a sub- +# matrix in the mathematical sense of the word. +# +# Arguments: +# name Name of the matrix. +# args rectangle to place into the serialized matrix +# +# Results: +# A list structure describing the part of the matrix which was serialized. + +proc ::struct::matrix::_serialize {name args} { + + # all - boolean flag - set if and only if the all nodes of the + # matrix are chosen for serialization. Because if that is true we + # can skip the step finding the relevant arcs and simply take all + # arcs. + + set nargs [llength $args] + if {($nargs != 0) && ($nargs != 4)} { + return -code error "$name: wrong # args: serialize ?column_tl row_tl column_br row_br?" + } + + variable ${name}::rows + variable ${name}::columns + + if {$nargs == 4} { + foreach {column_tl row_tl column_br row_br} $args break + + set column_tl [ChkColumnIndex $name $column_tl] + set row_tl [ChkRowIndex $name $row_tl] + set column_br [ChkColumnIndex $name $column_br] + set row_br [ChkRowIndex $name $row_br] + + if { + ($column_tl > $column_br) || + ($row_tl > $row_br) + } { + return -code error "Invalid cell indices, wrong ordering" + } + set rn [expr {$row_br - $row_tl + 1}] + set cn [expr {$column_br - $column_tl + 1}] + } else { + set column_tl 0 + set row_tl 0 + set column_br [expr {$columns - 1}] + set row_br [expr {$rows - 1}] + set rn $rows + set cn $columns + } + + # We could optimize and remove empty cells to the right and rows + # to the bottom. For now we don't. + + return [list \ + $rn $cn \ + [GetRect $name $column_tl $row_tl $column_br $row_br]] +} + +# ::struct::matrix::__set_cell -- +# +# Sets the value in the cell identified by row and column index +# to the data in the third argument. +# +# Arguments: +# name Name of the matrix object. +# column Column index of the cell to set. +# row Row index of the cell to set. +# value The new value of the cell. +# +# Results: +# None. + +proc ::struct::matrix::__set_cell {name column row value} { + set column [ChkColumnIndex $name $column] + set row [ChkRowIndex $name $row] + + variable ${name}::data + + if {![string compare $value $data($column,$row)]} { + # No change, ignore call! + return + } + + set data($column,$row) $value + + if {$value != {}} { + variable ${name}::colw + variable ${name}::rowh + catch {unset colw($column)} + catch {unset rowh($row)} + } + return +} + +# ::struct::matrix::__set_column -- +# +# Sets the values in the cells identified by the column index to +# the elements of the list provided as the third argument. Each +# element of the list is assigned to one cell, with the first +# element going into the cell in row 0 and then upward. If there +# are less values in the list than there are rows the remaining +# rows are set to the empty string. If there are more values in +# the list than there are rows the superfluous elements are +# ignored. The matrix is not extended by this operation. +# +# Arguments: +# name Name of the matrix. +# column Index of the column to set. +# values Values to set into the column. +# +# Results: +# None. + +proc ::struct::matrix::__set_column {name column values} { + set column [ChkColumnIndex $name $column] + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::rowh + variable ${name}::colw + + if {[set l [llength $values]] < $rows} { + # Missing values. Fill up with empty strings + + for {} {$l < $rows} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $rows} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$rows - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - Invalidate the column in the width cache. + # - The rows are either removed from the height cache or left + # unchanged, depending on the contents set into the cell. + + set r 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset rowh($r)} + } ; # {else leave the row unchanged} + set data($column,$r) $v + incr r + } + catch {unset colw($column)} + return +} + +# ::struct::matrix::__set_rect -- +# +# Takes a list of lists of cell values and writes them into the +# submatrix whose top-left cell is specified by the two +# indices. If the sublists of the outer list are not of equal +# length the shorter sublists will be filled with empty strings +# to the length of the longest sublist. If the submatrix +# specified by the top-left cell and the number of rows and +# columns in the "values" extends beyond the matrix we are +# modifying the over-extending parts of the values are ignored, +# i.e. essentially cut off. This subcommand expects its input in +# the format as returned by "getrect". +# +# Arguments: +# name Name of the matrix object. +# column Column index of the topleft cell to set. +# row Row index of the topleft cell to set. +# values Values to set. +# +# Results: +# None. + +proc ::struct::matrix::__set_rect {name column row values} { + # Allow negative indices! + set column [ChkColumnIndexNeg $name $column] + set row [ChkRowIndexNeg $name $row] + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::colw + variable ${name}::rowh + + if {$row < 0} { + # Remove rows from the head of values to restrict it to the + # overlapping area. + + set values [lrange $values [expr {0 - $row}] end] + set row 0 + } + + # Restrict it at the end too. + if {($row + [llength $values]) > $rows} { + set values [lrange $values 0 [expr {$rows - $row - 1}]] + } + + # Same for columns, but store it in some vars as this is required + # in a loop. + set firstcol 0 + if {$column < 0} { + set firstcol [expr {0 - $column}] + set column 0 + } + + # Now pan through values and area and copy the external data into + # the matrix. + + set r $row + foreach line $values { + set line [lrange $line $firstcol end] + + set l [expr {$column + [llength $line]}] + if {$l > $columns} { + set line [lrange $line 0 [expr {$columns - $column - 1}]] + } elseif {$l < [expr {$columns - $firstcol}]} { + # We have to take the offset into the line into account + # or we add fillers we don't need, overwriting part of the + # data array we shouldn't. + + for {} {$l < [expr {$columns - $firstcol}]} {incr l} { + lappend line {} + } + } + + set c $column + foreach cell $line { + if {$cell != {}} { + catch {unset rowh($r)} + catch {unset colw($c)} + } + set data($c,$r) $cell + incr c + } + incr r + } + return +} + +# ::struct::matrix::__set_row -- +# +# Sets the values in the cells identified by the row index to +# the elements of the list provided as the third argument. Each +# element of the list is assigned to one cell, with the first +# element going into the cell in column 0 and then upward. If +# there are less values in the list than there are columns the +# remaining columns are set to the empty string. If there are +# more values in the list than there are columns the superfluous +# elements are ignored. The matrix is not extended by this +# operation. +# +# Arguments: +# name Name of the matrix. +# row Index of the row to set. +# values Values to set into the row. +# +# Results: +# None. + +proc ::struct::matrix::__set_row {name row values} { + set row [ChkRowIndex $name $row] + SetRow $name $row $values +} + +proc ::struct::matrix::SetRow {name row values} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::colw + variable ${name}::rowh + + if {[set l [llength $values]] < $columns} { + # Missing values. Fill up with empty strings + + for {} {$l < $columns} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $columns} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$columns - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - Invalidate the row in the height cache. + # - The columns are either removed from the width cache or left + # unchanged, depending on the contents set into the cell. + + set c 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset colw($c)} + } ; # {else leave the row unchanged} + set data($c,$row) $v + incr c + } + catch {unset rowh($row)} + return +} + +# ::struct::matrix::__swap_columns -- +# +# Swaps the contents of the two specified columns. +# +# Arguments: +# name Name of the matrix. +# column_a Index of the first column to swap +# column_b Index of the second column to swap +# +# Results: +# None. + +proc ::struct::matrix::__swap_columns {name column_a column_b} { + set column_a [ChkColumnIndex $name $column_a] + set column_b [ChkColumnIndex $name $column_b] + return [SwapColumns $name $column_a $column_b] +} + +proc ::struct::matrix::SwapColumns {name column_a column_b} { + variable ${name}::data + variable ${name}::rows + variable ${name}::colw + + # Note: This operation does not influence the height cache for all + # rows and the width cache only insofar as its contents has to be + # swapped too for the two columns we are touching. Note that the + # cache might be partially filled or not at all, so we don't have + # to "swap" in some situations. + + for {set r 0} {$r < $rows} {incr r} { + set tmp $data($column_a,$r) + set data($column_a,$r) $data($column_b,$r) + set data($column_b,$r) $tmp + } + + set cwa [info exists colw($column_a)] + set cwb [info exists colw($column_b)] + + if {$cwa && $cwb} { + set tmp $colw($column_a) + set colw($column_a) $colw($column_b) + set colw($column_b) $tmp + } elseif {$cwa} { + # Move contents, don't swap. + set colw($column_b) $colw($column_a) + unset colw($column_a) + } elseif {$cwb} { + # Move contents, don't swap. + set colw($column_a) $colw($column_b) + unset colw($column_b) + } ; # else {nothing to do at all} + return +} + +# ::struct::matrix::__swap_rows -- +# +# Swaps the contents of the two specified rows. +# +# Arguments: +# name Name of the matrix. +# row_a Index of the first row to swap +# row_b Index of the second row to swap +# +# Results: +# None. + +proc ::struct::matrix::__swap_rows {name row_a row_b} { + set row_a [ChkRowIndex $name $row_a] + set row_b [ChkRowIndex $name $row_b] + return [SwapRows $name $row_a $row_b] +} + +proc ::struct::matrix::SwapRows {name row_a row_b} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rowh + + # Note: This operation does not influence the width cache for all + # columns and the height cache only insofar as its contents has to be + # swapped too for the two rows we are touching. Note that the + # cache might be partially filled or not at all, so we don't have + # to "swap" in some situations. + + for {set c 0} {$c < $columns} {incr c} { + set tmp $data($c,$row_a) + set data($c,$row_a) $data($c,$row_b) + set data($c,$row_b) $tmp + } + + set rha [info exists rowh($row_a)] + set rhb [info exists rowh($row_b)] + + if {$rha && $rhb} { + set tmp $rowh($row_a) + set rowh($row_a) $rowh($row_b) + set rowh($row_b) $tmp + } elseif {$rha} { + # Move contents, don't swap. + set rowh($row_b) $rowh($row_a) + unset rowh($row_a) + } elseif {$rhb} { + # Move contents, don't swap. + set rowh($row_a) $rowh($row_b) + unset rowh($row_b) + } ; # else {nothing to do at all} + return +} + +# ::struct::matrix::_transpose -- +# +# Exchanges rows and columns of the matrix +# +# Arguments: +# name Name of the matrix. +# +# Results: +# None. + +proc ::struct::matrix::_transpose {name} { + variable ${name}::rows + variable ${name}::columns + + if {$rows == 0} { + # Change the dimensions. + # There is no data to shift. + # The row/col caches are empty too. + + set rows $columns + set columns 0 + return + + } elseif {$columns == 0} { + # Change the dimensions. + # There is no data to shift. + # The row/col caches are empty too. + + set columns $rows + set rows 0 + return + } + + variable ${name}::data + variable ${name}::rowh + variable ${name}::colw + + # Exchanging the row/col caches is easy, independent of the actual + # dimensions of the matrix. + + set rhc [array get rowh] + set cwc [array get colw] + + unset rowh ; array set rowh $cwc + unset colw ; array set colw $rhc + + if {$rows == $columns} { + # A square matrix. We have to swap data around, but there is + # need to resize any of the arrays. Only the core is present. + + set n $columns + + } elseif {$rows > $columns} { + # Rectangular matrix, we have to delete rows, and add columns. + + for {set r $columns} {$r < $rows} {incr r} { + for {set c 0} {$c < $columns} {incr c} { + set data($r,$c) $data($c,$r) + unset data($c,$r) + } + } + + set n $columns ; # Size of the core. + } else { + # rows < columns. Rectangular matrix, we have to delete + # columns, and add rows. + + for {set c $rows} {$c < $columns} {incr c} { + for {set r 0} {$r < $rows} {incr r} { + set data($r,$c) $data($c,$r) + unset data($c,$r) + } + } + + set n $rows ; # Size of the core. + } + + set tmp $rows + set rows $columns + set columns $tmp + + # Whatever the actual dimensions, a square core is always + # present. The data of this core is now shuffled + + for {set i 0} {$i < $n} {incr i} { + for {set j $i ; incr j} {$j < $n} {incr j} { + set tmp $data($i,$j) + set data($i,$j) $data($j,$i) + set data($j,$i) $tmp + } + } + return +} + +# ::struct::matrix::_unlink -- +# +# Removes the link between the matrix and the specified +# arrayvariable, if there is one. +# +# Arguments: +# name Name of the matrix. +# avar Name of the linked array. +# +# Results: +# None. + +proc ::struct::matrix::_unlink {name avar} { + + variable ${name}::link + + if {![info exists link($avar)]} { + # Ignore unlinking of unknown variables. + return + } + + # Delete the traces first, then remove the link management + # information from the object. + + upvar #0 $avar array + variable ${name}::data + + trace remove variable array {write unset} [list ::struct::matrix::MatTraceIn $avar $name] + trace remove variable data write [list ::struct::matrix::MatTraceOut $avar $name] + + unset link($avar) + return +} + +# ::struct::matrix::ChkColumnIndex -- +# +# Helper to check and transform column indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of columns. +# +# Arguments: +# matrix Matrix to look at +# column The incoming index to check and transform +# +# Results: +# The absolute index to the column + +proc ::struct::matrix::ChkColumnIndex {name column} { + variable ${name}::columns + + switch -regexp -- $column { + {end-[0-9]+} { + set column [string map {end- ""} $column] + set cc [expr {$columns - 1 - $column}] + if {($cc < 0) || ($cc >= $columns)} { + return -code error "bad column index end-$column, column does not exist" + } + return $cc + } + end { + if {$columns <= 0} { + return -code error "bad column index $column, column does not exist" + } + return [expr {$columns - 1}] + } + {[0-9]+} { + if {($column < 0) || ($column >= $columns)} { + return -code error "bad column index $column, column does not exist" + } + return $column + } + default { + return -code error "bad column index \"$column\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkRowIndex -- +# +# Helper to check and transform row indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of rows. +# +# Arguments: +# matrix Matrix to look at +# row The incoming index to check and transform +# +# Results: +# The absolute index to the row + +proc ::struct::matrix::ChkRowIndex {name row} { + variable ${name}::rows + + switch -regexp -- $row { + {end-[0-9]+} { + set row [string map {end- ""} $row] + set rr [expr {$rows - 1 - $row}] + if {($rr < 0) || ($rr >= $rows)} { + return -code error "bad row index end-$row, row does not exist" + } + return $rr + } + end { + if {$rows <= 0} { + return -code error "bad row index $row, row does not exist" + } + return [expr {$rows - 1}] + } + {[0-9]+} { + if {($row < 0) || ($row >= $rows)} { + return -code error "bad row index $row, row does not exist" + } + return $row + } + default { + return -code error "bad row index \"$row\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkColumnIndexNeg -- +# +# Helper to check and transform column indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of columns +# (Accepts negative indices). +# +# Arguments: +# matrix Matrix to look at +# column The incoming index to check and transform +# +# Results: +# The absolute index to the column + +proc ::struct::matrix::ChkColumnIndexNeg {name column} { + variable ${name}::columns + + switch -regexp -- $column { + {end-[0-9]+} { + set column [string map {end- ""} $column] + set cc [expr {$columns - 1 - $column}] + if {$cc >= $columns} { + return -code error "bad column index end-$column, column does not exist" + } + return $cc + } + end { + return [expr {$columns - 1}] + } + {[0-9]+} { + if {$column >= $columns} { + return -code error "bad column index $column, column does not exist" + } + return $column + } + default { + return -code error "bad column index \"$column\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkRowIndexNeg -- +# +# Helper to check and transform row indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of rows +# (Accepts negative indices). +# +# Arguments: +# matrix Matrix to look at +# row The incoming index to check and transform +# +# Results: +# The absolute index to the row + +proc ::struct::matrix::ChkRowIndexNeg {name row} { + variable ${name}::rows + + switch -regexp -- $row { + {end-[0-9]+} { + set row [string map {end- ""} $row] + set rr [expr {$rows - 1 - $row}] + if {$rr >= $rows} { + return -code error "bad row index end-$row, row does not exist" + } + return $rr + } + end { + return [expr {$rows - 1}] + } + {[0-9]+} { + if {$row >= $rows} { + return -code error "bad row index $row, row does not exist" + } + return $row + } + default { + return -code error "bad row index \"$row\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkColumnIndexAll -- +# +# Helper to transform column indices. Returns the +# absolute index number belonging to the specified +# index. +# +# Arguments: +# matrix Matrix to look at +# column The incoming index to check and transform +# +# Results: +# The absolute index to the column + +proc ::struct::matrix::ChkColumnIndexAll {name column} { + variable ${name}::columns + + switch -regexp -- $column { + {end-[0-9]+} { + set column [string map {end- ""} $column] + set cc [expr {$columns - 1 - $column}] + return $cc + } + end { + return $columns + } + {[0-9]+} { + return $column + } + default { + return -code error "bad column index \"$column\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkRowIndexAll -- +# +# Helper to transform row indices. Returns the +# absolute index number belonging to the specified +# index. +# +# Arguments: +# matrix Matrix to look at +# row The incoming index to check and transform +# +# Results: +# The absolute index to the row + +proc ::struct::matrix::ChkRowIndexAll {name row} { + variable ${name}::rows + + switch -regexp -- $row { + {end-[0-9]+} { + set row [string map {end- ""} $row] + set rr [expr {$rows - 1 - $row}] + return $rr + } + end { + return $rows + } + {[0-9]+} { + return $row + } + default { + return -code error "bad row index \"$row\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::MatTraceIn -- +# +# Helper propagating changes made to an array +# into the matrix the array is linked to. +# +# Arguments: +# avar Name of the array which was changed. +# name Matrix to write the changes to. +# var,idx,op Standard trace arguments +# +# Results: +# None. + +proc ::struct::matrix::MatTraceIn {avar name var idx op} { + # Propagate changes in the linked array back into the matrix. + + variable ${name}::lock + if {$lock} {return} + + # We have to cover two possibilities when encountering an "unset" operation ... + # 1. The external array was destroyed: perform automatic unlink. + # 2. An individual element was unset: Set the corresponding cell to the empty string. + # See SF Tcllib Bug #532791. + + if {(![string compare $op unset]) && ($idx == {})} { + # Possibility 1: Array was destroyed + $name unlink $avar + return + } + + upvar #0 $avar array + variable ${name}::data + variable ${name}::link + + set transpose $link($avar) + if {$transpose} { + foreach {r c} [split $idx ,] break + } else { + foreach {c r} [split $idx ,] break + } + + # Use standard method to propagate the change. + # => Get automatically index checks, cache updates, ... + + if {![string compare $op unset]} { + # Unset possibility 2: Element was unset. + # Note: Setting the cell to the empty string will + # invoke MatTraceOut for this array and thus try + # to recreate the destroyed element of the array. + # We don't want this. But we do want to propagate + # the change to other arrays, as "unset". To do + # all of this we use another state variable to + # signal this situation. + + variable ${name}::unset + set unset $avar + + $name set cell $c $r "" + + set unset {} + return + } + + $name set cell $c $r $array($idx) + return +} + +# ::struct::matrix::MatTraceOut -- +# +# Helper propagating changes made to the matrix into the linked arrays. +# +# Arguments: +# avar Name of the array to write the changes to. +# name Matrix which was changed. +# var,idx,op Standard trace arguments +# +# Results: +# None. + +proc ::struct::matrix::MatTraceOut {avar name var idx op} { + # Propagate changes in the matrix data array into the linked array. + + variable ${name}::unset + + if {![string compare $avar $unset]} { + # Do not change the variable currently unsetting + # one of its elements. + return + } + + variable ${name}::lock + set lock 1 ; # Disable MatTraceIn [#532783] + + upvar #0 $avar array + variable ${name}::data + variable ${name}::link + + set transpose $link($avar) + + if {$transpose} { + foreach {r c} [split $idx ,] break + } else { + foreach {c r} [split $idx ,] break + } + + if {$unset != {}} { + # We are currently propagating the unset of an + # element in a different linked array to this + # array. We make sure that this is an unset too. + + unset array($c,$r) + } else { + set array($c,$r) $data($idx) + } + set lock 0 + return +} + +# ::struct::matrix::SortMaxHeapify -- +# +# Helper for the 'sort' method. Performs the central algorithm +# which converts the matrix into a heap, easily sortable. +# +# Arguments: +# name Matrix object which is sorted. +# i Index of the row/column currently being sorted. +# key Index of the column/row to sort the rows/columns by. +# rowCol Indicator if we are sorting rows ('r'), or columns ('c'). +# heapSize Number of rows/columns to sort. +# rev Boolean flag, set if sorting is done revers (-decreasing). +# +# Sideeffects: +# Transforms the matrix into a heap of rows/columns, +# swapping them around. +# +# Results: +# None. + +proc ::struct::matrix::SortMaxHeapify {name i key rowCol heapSize {rev 0}} { + # MAX-HEAPIFY, adapted by EAS from CLRS 6.2 + switch $rowCol { + r { set A [GetColumn $name $key] } + c { set A [GetRow $name $key] } + } + # Weird expressions below for clarity, as CLRS uses A[1...n] + # format and TCL uses A[0...n-1] + set left [expr {int(2*($i+1) -1)}] + set right [expr {int(2*($i+1)+1 -1)}] + + # left, right are tested as < rather than <= because they are + # in A[0...n-1] + if { + $left < $heapSize && + ( !$rev && [lindex $A $left] > [lindex $A $i] || + $rev && [lindex $A $left] < [lindex $A $i] ) + } { + set largest $left + } else { + set largest $i + } + + if { + $right < $heapSize && + ( !$rev && [lindex $A $right] > [lindex $A $largest] || + $rev && [lindex $A $right] < [lindex $A $largest] ) + } { + set largest $right + } + + if { $largest != $i } { + switch $rowCol { + r { SwapRows $name $i $largest } + c { SwapColumns $name $i $largest } + } + SortMaxHeapify $name $largest $key $rowCol $heapSize $rev + } + return +} + +# ::struct::matrix::CheckSerialization -- +# +# Validate the serialization of a matrix. +# +# Arguments: +# ser Serialization to validate. +# rvar Variable to store the number of rows into. +# cvar Variable to store the number of columns into. +# dvar Variable to store the matrix data into. +# +# Results: +# none + +proc ::struct::matrix::CheckSerialization {ser rvar cvar dvar} { + upvar 1 \ + $rvar rows \ + $cvar columns \ + $dvar data + + # Overall length ok ? + if {[llength $ser] != 3} { + return -code error \ + "error in serialization: list length not 3." + } + + foreach {r c d} $ser break + + # Check rows/columns information + + if {![string is integer -strict $r] || ($r < 0)} { + return -code error \ + "error in serialization: bad number of rows \"$r\"." + } + if {![string is integer -strict $c] || ($c < 0)} { + return -code error \ + "error in serialization: bad number of columns \"$c\"." + } + + # Validate data against rows/columns. We can have less data than + # rows or columns, the missing cells will be initialized to the + # empty string. But too many is considered as a signal of + # being something wrong. + + if {[llength $d] > $r} { + return -code error \ + "error in serialization: data for to many rows." + } + foreach rv $d { + if {[llength $rv] > $c} { + return -code error \ + "error in serialization: data for to many columns." + } + } + + # Ok. The data is now ready for the caller. + + set data $d + set rows $r + set columns $c + return +} + +# ::struct::matrix::DeleteRows -- +# +# Deletes n rows from the bottom of the matrix. +# +# Arguments: +# name Name of the matrix. +# n The number of rows to delete (no greater than the number of rows). +# +# Results: +# None. + +proc ::struct::matrix::DeleteRows {name n} { + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher rows down and then delete the + # superfluous data in the old last row. Move the data in the + # height cache too, take partial fill into account there too. + # Invalidate the width cache for all columns. + + set rowstart [expr {$rows - $n}] + + for {set c 0} {$c < $columns} {incr c} { + for {set r $rowstart} {$r < $rows} {incr r} { + unset data($c,$r) + catch {unset rowh($r)} + } + catch {unset colw($c)} + } + set rows $rowstart + return +} + +# ::struct::matrix::DeleteColumns -- +# +# Deletes n columns from the right of the matrix. +# +# Arguments: +# name Name of the matrix. +# n The number of columns to delete. +# +# Results: +# None. + +proc ::struct::matrix::DeleteColumns {name n} { + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher columns down and then delete the + # superfluous data in the old last column. Move the data in the + # width cache too, take partial fill into account there too. + # Invalidate the height cache for all rows. + + set colstart [expr {$columns - $n}] + + for {set r 0} {$r < $rows} {incr r} { + for {set c $colstart} {$c < $columns} {incr c} { + unset data($c,$r) + catch {unset colw($c)} + } + catch {unset rowh($r)} + } + set columns $colstart + return +} + +# ::struct::matrix::TermWidth -- +# +# Computes the number of terminal columns taken by the input string. +# This discounts ANSI color codes as zero-width, and asian characters +# as double-width. +# +# Arguments: +# str String to process +# +# Results: +# Number of terminal columns covered by string argument + +proc ::struct::matrix::TermWidth {str} { + # Look for ANSI color control sequences and remove them. Avoid counting their characters as such + # sequences as a whole represent a state change, and are logically of zero/no width. + # Further use wcswidth to account for double-wide Asian characters. + + regsub -all "\033\\\[\[0-9;\]*m" $str {} str + return [textutil::wcswidth $str] +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'matrix::matrix' into the general structure namespace. + namespace import -force matrix::matrix + namespace export matrix +} +package provide struct::matrix 2.2 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/pkgIndex.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/pkgIndex.tcl new file mode 100644 index 00000000..001cf324 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/pkgIndex.tcl @@ -0,0 +1,25 @@ +if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} +package ifneeded struct 2.2 [list source [file join $dir struct.tcl]] +package ifneeded struct 1.5 [list source [file join $dir struct1.tcl]] + +package ifneeded struct::queue 1.4.6 [list source [file join $dir queue.tcl]] +package ifneeded struct::stack 1.5.4 [list source [file join $dir stack.tcl]] +package ifneeded struct::tree 2.1.3 [list source [file join $dir tree.tcl]] +package ifneeded struct::pool 1.2.4 [list source [file join $dir pool.tcl]] +package ifneeded struct::record 1.2.3 [list source [file join $dir record.tcl]] +package ifneeded struct::set 2.2.4 [list source [file join $dir sets.tcl]] +package ifneeded struct::prioqueue 1.5 [list source [file join $dir prioqueue.tcl]] +package ifneeded struct::skiplist 1.4 [list source [file join $dir skiplist.tcl]] + +package ifneeded struct::graph 1.2.2 [list source [file join $dir graph1.tcl]] +package ifneeded struct::tree 1.2.3 [list source [file join $dir tree1.tcl]] + +package ifneeded struct::list 1.8.6 [list source [file join $dir list.tcl]] +package ifneeded struct::list::test 1.8.5 [list source [file join $dir list.test.tcl]] +package ifneeded struct::graph 2.4.4 [list source [file join $dir graph.tcl]] +package ifneeded struct::map 1.1 [list source [file join $dir map.tcl]] + +package ifneeded struct::matrix 2.2 [list source [file join $dir matrix.tcl]] + +package ifneeded struct::disjointset 1.2 [list source [file join $dir disjointset.tcl]] +package ifneeded struct::graph::op 0.11.4 [list source [file join $dir graphops.tcl]] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/pool.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/pool.tcl new file mode 100644 index 00000000..1d14768c --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/pool.tcl @@ -0,0 +1,715 @@ +################################################################################ +# pool.tcl +# +# +# Author: Erik Leunissen +# +# +# Acknowledgement: +# The author is grateful for the advice provided by +# Andreas Kupries during the development of this code. +# +################################################################################ + +package require cmdline + +namespace eval ::struct {} +namespace eval ::struct::pool { + + # a list of all current pool names + variable pools {} + + # counter is used to give a unique name to a pool if + # no name was supplied, e.g. pool1, pool2 etc. + variable counter 0 + + # `commands' is the list of subcommands recognized by a pool-object command + variable commands {add clear destroy info maxsize release remove request} + + # All errors with corresponding (unformatted) messages. + # The format strings will be replaced by the appropriate + # values when an error occurs. + variable Errors + array set Errors { + BAD_SUBCMD {Bad subcommand "%s": must be %s} + DUPLICATE_ITEM_IN_ARGS {Duplicate item `%s' in arguments.} + DUPLICATE_POOLNAME {The pool `%s' already exists.} + EXCEED_MAXSIZE "This command would increase the total number of items\ + \nbeyond the maximum size of the pool. No items registered." + FORBIDDEN_ALLOCID "The value -1 is not allowed as an allocID." + INVALID_POOLSIZE {The pool currently holds %s items.\ + Can't set maxsize to a value less than that.} + ITEM_ALREADY_IN_POOL {`%s' already is a member of the pool. No items registered.} + ITEM_NOT_IN_POOL {`%s' is not a member of %s.} + ITEM_NOT_ALLOCATED {Can't release `%s' because it isn't allocated.} + ITEM_STILL_ALLOCATED {Can't remove `%s' because it is still allocated.} + NONINT_REQSIZE {The second argument must be a positive integer value} + SOME_ITEMS_NOT_FREE {Couldn't %s `%s' because some items are still allocated.} + UNKNOWN_ARG {Unknown argument `%s'} + UNKNOWN_POOL {Nothing known about `%s'.} + VARNAME_EXISTS {A variable `::struct::pool::%s' already exists.} + WRONG_INFO_TYPE "Expected second argument to be one of:\ + \n allitems, allocstate, cursize, freeitems, maxsize,\ + \nbut received: `%s'." + WRONG_NARGS "wrong#args" + } + + namespace export pool +} + +# A small helper routine to generate structured errors + +if {[package vsatisfies [package present Tcl] 8.5 9]} { + # Tcl 8.5+, have expansion operator and syntax. And option -level. + proc ::struct::pool::Error {error args} { + variable Errors + return -code error -level 1 \ + -errorcode [list STRUCT POOL $error {*}$args] \ + [format $Errors($error) {*}$args] + } +} else { + # Tcl 8.4. No expansion operator available. Nor -level. + # Construct the pieces explicitly, via linsert/eval hop&dance. + proc ::struct::pool::Error {error args} { + variable Errors + lappend code STRUCT POOL $error + eval [linsert $args 0 lappend code] + set msg [eval [linsert $args 0 format $Errors($error)]] + return -code error -errorcode $code $msg + } +} + +# A small helper routine to check list membership +proc ::struct::pool::lmember {list element} { + if { [lsearch -exact $list $element] >= 0 } { + return 1 + } else { + return 0 + } +} + +# General note +# ============ +# +# All procedures below use the following method to reference +# a particular pool-object: +# +# variable $poolname +# upvar #0 ::struct::pool::$poolname pool +# upvar #0 ::struct::pool::Allocstate_$poolname state +# +# Therefore, the names `pool' and `state' refer to a particular +# instance of a pool. +# +# In the comments to the code below, the words `pool' and `state' +# also refer to a particular pool. +# + +# ::struct::pool::create +# +# Creates a new instance of a pool (a pool-object). +# ::struct::pool::pool (see right below) is an alias to this procedure. +# +# +# Arguments: +# poolname: name of the pool-object +# maxsize: the maximum number of elements that the pool is allowed +# consist of. +# +# +# Results: +# the name of the newly created pool +# +# +# Side effects: +# - Registers the pool-name in the variable `pools'. +# +# - Creates the pool array which holds general state about the pool. +# The following elements are initialized: +# pool(freeitems): a list of non-allocated items +# pool(cursize): the current number of elements in the pool +# pool(maxsize): the maximum allowable number of pool elements +# Additional state may be hung off this array as long as the three +# elements above are not corrupted. +# +# - Creates a separate array `state' that will hold allocation state +# of the pool elements. +# +# - Creates an object-procedure that has the same name as the pool. +# +proc ::struct::pool::create { {poolname ""} {maxsize 10} } { + variable pools + variable counter + + # check maxsize argument + if { ![string equal $maxsize 10] } { + if { ![regexp {^\+?[1-9][0-9]*$} $maxsize] } { + Error NONINT_REQSIZE + } + } + + # create a name if no name was supplied + if { [string length $poolname]==0 } { + incr counter + set poolname pool$counter + set incrcnt 1 + } + + # check whether there exists a pool named $poolname + if { [lmember $pools $poolname] } { + if { [::info exists incrcnt] } { + incr counter -1 + } + Error DUPLICATE_POOLNAME $poolname + } + + # check whether the namespace variable exists + if { [::info exists ::struct::pool::$poolname] } { + if { [::info exists incrcnt] } { + incr counter -1 + } + Error VARNAME_EXISTS $poolname + } + + variable $poolname + + # register + lappend pools $poolname + + # create and initialize the new pool data structure + upvar #0 ::struct::pool::$poolname pool + set pool(freeitems) {} + set pool(maxsize) $maxsize + set pool(cursize) 0 + + # the array that holds allocation state + upvar #0 ::struct::pool::Allocstate_$poolname state + array set state {} + + # create a pool-object command and map it to the pool commands + interp alias {} ::$poolname {} ::struct::pool::poolCmd $poolname + return $poolname +} + +# +# This alias provides compatibility with the implementation of the +# other data structures (stack, queue etc...) in the tcllib::struct package. +# +proc ::struct::pool::pool { {poolname ""} {maxsize 10} } { + ::struct::pool::create $poolname $maxsize +} + + +# ::struct::pool::poolCmd +# +# This proc constitutes a level of indirection between the pool-object +# subcommand and the pool commands (below); it's sole function is to pass +# the command along to one of the pool commands, and receive any results. +# +# Arguments: +# poolname: name of the pool-object +# subcmd: the subcommand, which identifies the pool-command to +# which calls will be passed. +# args: any arguments. They will be inspected by the pool-command +# to which this call will be passed along. +# +# Results: +# Whatever result the pool command returns, is once more returned. +# +# Side effects: +# Dispatches the call onto a specific pool command and receives any results. +# +proc ::struct::pool::poolCmd {poolname subcmd args} { + # check the subcmd argument + if { [lsearch -exact $::struct::pool::commands $subcmd] == -1 } { + set optlist [join $::struct::pool::commands ", "] + set optlist [linsert $optlist "end-1" "or"] + Error BAD_SUBCMD $subcmd $optlist + } + + # pass the call to the pool command indicated by the subcmd argument, + # and return the result from that command. + return [eval [linsert $args 0 ::struct::pool::$subcmd $poolname]] +} + + +# ::struct::pool::destroy +# +# Destroys a pool-object, its associated variables and "object-command" +# +# Arguments: +# poolname: name of the pool-object +# forceArg: if set to `-force', the pool-object will be destroyed +# regardless the allocation state of its objects. +# +# Results: +# none +# +# Side effects: +# - unregisters the pool name in the variable `pools'. +# - unsets `pool' and `state' (poolname specific variables) +# - destroys the "object-procedure" that was associated with the pool. +# +proc ::struct::pool::destroy {poolname {forceArg ""}} { + variable pools + + # check forceArg argument + if { [string length $forceArg] } { + if { [string equal $forceArg -force] } { + set force 1 + } else { + Error UNKNOWN_ARG $forceArg + } + } else { + set force 0 + } + + set index [lsearch -exact $pools $poolname] + if {$index == -1 } { + Error UNKNOWN_POOL $poolname + } + + if { !$force } { + # check for any lingering allocated items + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + if { [llength $pool(freeitems)] != $pool(cursize) } { + Error SOME_ITEMS_NOT_FREE destroy $poolname + } + } + + rename ::$poolname {} + unset ::struct::pool::$poolname + catch {unset ::struct::pool::Allocstate_$poolname} + set pools [lreplace $pools $index $index] + + return +} + + +# ::struct::pool::add +# +# Add items to the pool +# +# Arguments: +# poolname: name of the pool-object +# args: the items to add +# +# Results: +# none +# +# Side effects: +# sets the initial allocation state of the added items to -1 (free) +# +proc ::struct::pool::add {poolname args} { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # argument check + if { [llength $args] == 0 } { + Error WRONG_NARGS + } + + # will this operation exceed the size limit of the pool? + if {[expr { $pool(cursize) + [llength $args] }] > $pool(maxsize) } { + Error EXCEED_MAXSIZE + } + + + # check for duplicate items on the command line + set N [llength $args] + if { $N > 1} { + for {set i 0} {$i<=$N} {incr i} { + foreach item [lrange $args [expr {$i+1}] end] { + if { [string equal [lindex $args $i] $item]} { + Error DUPLICATE_ITEM_IN_ARGS $item + } + } + } + } + + # check whether the items exist yet in the pool + foreach item $args { + if { [lmember [array names state] $item] } { + Error ITEM_ALREADY_IN_POOL $item + } + } + + # add items to the pool, and initialize their allocation state + foreach item $args { + lappend pool(freeitems) $item + set state($item) -1 + incr pool(cursize) + } + return +} + + + +# ::struct::pool::clear +# +# Removes all items from the pool and clears corresponding +# allocation state. +# +# +# Arguments: +# poolname: name of the pool-object +# forceArg: if set to `-force', all items are removed +# regardless their allocation state. +# +# Results: +# none +# +# Side effects: +# see description above +# +proc ::struct::pool::clear {poolname {forceArg ""} } { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # check forceArg argument + if { [string length $forceArg] } { + if { [string equal $forceArg -force] } { + set force 1 + } else { + Error UNKNOWN_ARG $forceArg + } + } else { + set force 0 + } + + # check whether some items are still allocated + if { !$force } { + if { [llength $pool(freeitems)] != $pool(cursize) } { + Error SOME_ITEMS_NOT_FREE clear $poolname + } + } + + # clear the pool, clean up state and adjust the pool size + set pool(freeitems) {} + array unset state + array set state {} + set pool(cursize) 0 + return +} + + + +# ::struct::pool::info +# +# Returns information about the pool in data structures that allow +# further programmatic use. +# +# Arguments: +# poolname: name of the pool-object +# type: the type of info requested +# +# +# Results: +# The info requested +# +# +# Side effects: +# none +# +proc ::struct::pool::info {poolname type args} { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # check the number of arguments + if { [string equal $type allocID] } { + if { [llength $args]!=1 } { + Error WRONG_NARGS + } + } elseif { [llength $args] > 0 } { + Error WRONG_NARGS + } + + switch $type { + allitems { + return [array names state] + } + allocstate { + return [array get state] + } + allocID { + set item [lindex $args 0] + if {![lmember [array names state] $item]} { + Error ITEM_NOT_IN_POOL $item $poolname + } + return $state($item) + } + cursize { + return $pool(cursize) + } + freeitems { + return $pool(freeitems) + } + maxsize { + return $pool(maxsize) + } + default { + Error WRONG_INFO_TYPE $type + } + } +} + + +# ::struct::pool::maxsize +# +# Returns the current or sets a new maximum size of the pool. +# As far as querying only is concerned, this is an alias for +# `::struct::pool::info maxsize'. +# +# +# Arguments: +# poolname: name of the pool-object +# reqsize: if supplied, it is the requested size of the pool, i.e. +# the maximum number of elements in the pool. +# +# +# Results: +# The current/new maximum size of the pool. +# +# +# Side effects: +# Sets pool(maxsize) if a new size is supplied. +# +proc ::struct::pool::maxsize {poolname {reqsize ""} } { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + if { [string length $reqsize] } { + if { [regexp {^\+?[1-9][0-9]*$} $reqsize] } { + if { $pool(cursize) <= $reqsize } { + set pool(maxsize) $reqsize + } else { + Error INVALID_POOLSIZE $pool(cursize) + } + } else { + Error NONINT_REQSIZE + } + } + return $pool(maxsize) +} + + +# ::struct::pool::release +# +# Deallocates an item +# +# +# Arguments: +# poolname: name of the pool-object +# item: name of the item to be released +# +# +# Results: +# none +# +# Side effects: +# - sets the item's allocation state to free (-1) +# - appends item to the list of free items +# +proc ::struct::pool::release {poolname item} { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # Is item in the pool? + if {![lmember [array names state] $item]} { + Error ITEM_NOT_IN_POOL $item $poolname + } + + # check whether item was allocated + if { $state($item) == -1 } { + Error ITEM_NOT_ALLOCATED $item + } else { + + # set item free and return it to the pool of free items + set state($item) -1 + lappend pool(freeitems) $item + + } + return +} + +# ::struct::pool::remove +# +# Removes an item from the pool +# +# +# Arguments: +# poolname: name of the pool-object +# item: the item to be removed +# forceArg: if set to `-force', the item is removed +# regardless its allocation state. +# +# Results: +# none +# +# Side effects: +# - cleans up allocation state related to the item +# +proc ::struct::pool::remove {poolname item {forceArg ""} } { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # check forceArg argument + if { [string length $forceArg] } { + if { [string equal $forceArg -force] } { + set force 1 + } else { + Error UNKNOWN_ARG $forceArg + } + } else { + set force 0 + } + + # Is item in the pool? + if {![lmember [array names state] $item]} { + Error ITEM_NOT_IN_POOL $item $poolname + } + + set index [lsearch $pool(freeitems) $item] + if { $index >= 0} { + + # actual removal + set pool(freeitems) [lreplace $pool(freeitems) $index $index] + + } elseif { !$force } { + Error ITEM_STILL_ALLOCATED $item + } + + # clean up state and adjust the pool size + unset state($item) + incr pool(cursize) -1 + return +} + + + +# ::struct::pool::request +# +# Handles requests for an item, taking into account a preference +# for a particular item if supplied. +# +# +# Arguments: +# poolname: name of the pool-object +# +# itemvar: variable to which the item-name will be assigned +# if the request is honored. +# +# args: an optional sequence of key-value pairs, indicating the +# following options: +# -prefer: the preferred item to allocate. +# -allocID: An ID for the entity to which the item will be +# allocated. This facilitates reverse lookups. +# +# Results: +# +# 1 if the request was honored; an item is allocated +# 0 if the request couldn't be honored; no item is allocated +# +# The user is strongly advised to check the return values +# when calling this procedure. +# +# +# Side effects: +# +# if the request is honored: +# - sets allocation state to $allocID (or dummyID if it was not supplied) +# if allocation was succesful. Allocation state is maintained in the +# namespace variable state (see: `General note' above) +# - sets the variable passed via `itemvar' to the allocated item. +# +# if the request is denied, no side effects occur. +# +proc ::struct::pool::request {poolname itemvar args} { + variable $poolname + upvar #0 ::struct::pool::$poolname pool + upvar #0 ::struct::pool::Allocstate_$poolname state + + # check args + set nargs [llength $args] + if { ! ($nargs==0 || $nargs==2 || $nargs==4) } { + if { ![string equal $args -?] && ![string equal $args -help]} { + Error WRONG_NARGS + } + } elseif { $nargs } { + foreach {name value} $args { + if { ![string match -* $name] } { + Error UNKNOWN_ARG $name + } + } + } + + set allocated 0 + + # are there any items available? + if { [llength $pool(freeitems)] > 0} { + + # process command options + set options [cmdline::getoptions args { \ + {prefer.arg {} {The preference for a particular item}} \ + {allocID.arg {} {An ID for the entity to which the item will be allocated} } \ + } \ + "usage: $poolname request itemvar ?options?:"] + foreach {key value} $options { + set $key $value + } + + if { $allocID == -1 } { + Error FORBIDDEN_ALLOCID + } + + # let `item' point to a variable two levels up the call stack + upvar 2 $itemvar item + + # check whether a preference was supplied + if { [string length $prefer] } { + if {![lmember [array names state] $prefer]} { + Error ITEM_NOT_IN_POOL $prefer $poolname + } + if { $state($prefer) == -1 } { + set index [lsearch $pool(freeitems) $prefer] + set item $prefer + } else { + return 0 + } + } else { + set index 0 + set item [lindex $pool(freeitems) 0] + } + + # do the actual allocation + set pool(freeitems) [lreplace $pool(freeitems) $index $index] + if { [string length $allocID] } { + set state($item) $allocID + } else { + set state($item) dummyID + } + set allocated 1 + } + return $allocated +} + + +# EOF pool.tcl + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'pool::pool' into the general structure namespace. + namespace import -force pool::pool + namespace export pool +} +package provide struct::pool 1.2.4 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/prioqueue.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/prioqueue.tcl new file mode 100644 index 00000000..b47feafb --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/prioqueue.tcl @@ -0,0 +1,535 @@ +# prioqueue.tcl -- +# +# Priority Queue implementation for Tcl. +# +# adapted from queue.tcl +# Copyright (c) 2002,2003 Michael Schlenker +# Copyright (c) 2008 Alejandro Paz +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: prioqueue.tcl,v 1.10 2008/09/04 04:35:02 andreas_kupries Exp $ + +package require Tcl 8.5 9 + +namespace eval ::struct {} + +namespace eval ::struct::prioqueue { + # The queues array holds all of the queues you've made + variable queues + + # counter is used to give a unique name for unnamed queues + variable counter 0 + + # commands is the list of subcommands recognized by the queue + variable commands [list \ + "clear" \ + "destroy" \ + "get" \ + "peek" \ + "put" \ + "remove" \ + "size" \ + "peekpriority" \ + ] + + variable sortopt [list \ + "-integer" \ + "-real" \ + "-ascii" \ + "-dictionary" \ + ] + + # this is a simple design decision, that integer and real + # are sorted decreasing (-1), and -ascii and -dictionary are sorted -increasing (1) + # the values here map to the sortopt list + # could be changed to something configurable. + variable sortdir [list \ + "-1" \ + "-1" \ + "1" \ + "1" \ + ] + + + + # Only export one command, the one used to instantiate a new queue + namespace export prioqueue + + proc K {x y} {set x} ;# DKF's K combinator +} + +# ::struct::prioqueue::prioqueue -- +# +# Create a new prioqueue with a given name; if no name is given, use +# prioqueueX, where X is a number. +# +# Arguments: +# sorting sorting option for lsort to use, no -command option +# defaults to integer +# name name of the queue; if null, generate one. +# names may not begin with - +# +# +# Results: +# name name of the queue created + +proc ::struct::prioqueue::prioqueue {args} { + variable queues + variable counter + variable queues_sorting + variable sortopt + + # check args + if {[llength $args] > 2} { + error "wrong # args: should be \"[lindex [info level 0] 0] ?-ascii|-dictionary|-integer|-real? ?name?\"" + } + if {[llength $args] == 0} { + # defaulting to integer priorities + set sorting -integer + } else { + if {[llength $args] == 1} { + if {[string match "-*" [lindex $args 0]]==1} { + set sorting [lindex $args 0] + } else { + set sorting -integer + set name [lindex $args 0] + } + } else { + if {[llength $args] == 2} { + foreach {sorting name} $args {break} + } + } + } + # check option (like lsort sorting options without -command) + if {[lsearch $sortopt $sorting] == -1} { + # if sortoption is unknown, but name is a sortoption we give a better error message + if {[info exists name] && [lsearch $sortopt $name]!=-1} { + error "wrong argument position: should be \"[lindex [info level 0] 0] ?-ascii|-dictionary|-integer|-real? ?name?\"" + } + error "unknown sort option \"$sorting\"" + } + # create name if not given + if {![info exists name]} { + incr counter + set name "prioqueue${counter}" + } + + if { ![string equal [info commands ::$name] ""] } { + error "command \"$name\" already exists, unable to create prioqueue" + } + + # Initialize the queue as empty + set queues($name) [list ] + switch -exact -- $sorting { + -integer { set queues_sorting($name) 0} + -real { set queues_sorting($name) 1} + -ascii { set queues_sorting($name) 2} + -dictionary { set queues_sorting($name) 3} + } + + # Create the command to manipulate the queue + interp alias {} ::$name {} ::struct::prioqueue::QueueProc $name + + return $name +} + +########################## +# Private functions follow + +# ::struct::prioqueue::QueueProc -- +# +# Command that processes all queue object commands. +# +# Arguments: +# name name of the queue object to manipulate. +# args command name and args for the command +# +# Results: +# Varies based on command to perform + +proc ::struct::prioqueue::QueueProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + if { [string equal [info commands ::struct::prioqueue::_$cmd] ""] } { + variable commands + set optlist [join $commands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + return [eval [linsert $args 0 ::struct::prioqueue::_$cmd $name]] +} + +# ::struct::prioqueue::_clear -- +# +# Clear a queue. +# +# Arguments: +# name name of the queue object. +# +# Results: +# None. + +proc ::struct::prioqueue::_clear {name} { + variable queues + set queues($name) [list] + return +} + +# ::struct::prioqueue::_destroy -- +# +# Destroy a queue object by removing it's storage space and +# eliminating it's proc. +# +# Arguments: +# name name of the queue object. +# +# Results: +# None. + +proc ::struct::prioqueue::_destroy {name} { + variable queues + variable queues_sorting + unset queues($name) + unset queues_sorting($name) + interp alias {} ::$name {} + return +} + +# ::struct::prioqueue::_get -- +# +# Get an item from a queue. +# +# Arguments: +# name name of the queue object. +# count number of items to get; defaults to 1 +# +# Results: +# item first count items from the queue; if there are not enough +# items in the queue, throws an error. +# + +proc ::struct::prioqueue::_get {name {count 1}} { + variable queues + if { $count < 1 } { + error "invalid item count $count" + } + + if { $count > [llength $queues($name)] } { + error "insufficient items in prioqueue to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item gets aren't listified + set item [lindex [lindex $queues($name) 0] 1] + set queues($name) [lreplace [K $queues($name) [set queues($name) ""]] 0 0] + return $item + } + + # Otherwise, return a list of items + incr count -1 + set items [lrange $queues($name) 0 $count] + foreach item $items { + lappend result [lindex $item 1] + } + set items "" + + set queues($name) [lreplace [K $queues($name) [set queues($name) ""]] 0 $count] + return $result +} + +# ::struct::prioqueue::_peek -- +# +# Retrive the value of an item on the queue without removing it. +# +# Arguments: +# name name of the queue object. +# count number of items to peek; defaults to 1 +# +# Results: +# items top count items from the queue; if there are not enough items +# to fufill the request, throws an error. + +proc ::struct::prioqueue::_peek {name {count 1}} { + variable queues + if { $count < 1 } { + error "invalid item count $count" + } + + if { $count > [llength $queues($name)] } { + error "insufficient items in prioqueue to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item pops aren't listified + return [lindex [lindex $queues($name) 0] 1] + } + + # Otherwise, return a list of items + set index [expr {$count - 1}] + foreach item [lrange $queues($name) 0 $index] { + lappend result [lindex $item 1] + } + return $result +} + +# ::struct::prioqueue::_peekpriority -- +# +# Retrive the priority of an item on the queue without removing it. +# +# Arguments: +# name name of the queue object. +# count number of items to peek; defaults to 1 +# +# Results: +# items top count items from the queue; if there are not enough items +# to fufill the request, throws an error. + +proc ::struct::prioqueue::_peekpriority {name {count 1}} { + variable queues + if { $count < 1 } { + error "invalid item count $count" + } + + if { $count > [llength $queues($name)] } { + error "insufficient items in prioqueue to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item pops aren't listified + return [lindex [lindex $queues($name) 0] 0] + } + + # Otherwise, return a list of items + set index [expr {$count - 1}] + foreach item [lrange $queues($name) 0 $index] { + lappend result [lindex $item 0] + } + return $result +} + + +# ::struct::prioqueue::_put -- +# +# Put an item into a queue. +# +# Arguments: +# name name of the queue object +# args list of the form "item1 prio1 item2 prio2 item3 prio3" +# +# Results: +# None. + +proc ::struct::prioqueue::_put {name args} { + variable queues + variable queues_sorting + variable sortopt + variable sortdir + + if { [llength $args] == 0 || [llength $args] % 2} { + error "wrong # args: should be \"$name put item prio ?item prio ...?\"" + } + + # check for prio type before adding + switch -exact -- $queues_sorting($name) { + 0 { + foreach {item prio} $args { + if {![string is integer -strict $prio]} { + error "priority \"$prio\" is not an integer type value" + } + } + } + 1 { + foreach {item prio} $args { + if {![string is double -strict $prio]} { + error "priority \"$prio\" is not a real type value" + } + } + } + default { + #no restrictions for -ascii and -dictionary + } + } + + # sort by priorities + set opt [lindex $sortopt $queues_sorting($name)] + set dir [lindex $sortdir $queues_sorting($name)] + + # add only if check has passed + foreach {item prio} $args { + set new [list $prio $item] + set queues($name) [__linsertsorted [K $queues($name) [set queues($name) ""]] $new $opt $dir] + } + return +} + +# ::struct::prioqueue::_remove -- +# +# Delete an item together with it's related priority value from the queue. +# +# Arguments: +# name name of the queue object +# item item to be removed +# +# Results: +# None. + +if {[package vcompare [package present Tcl] 8.5] < 0} { + # 8.4-: We have -index option for lsearch, so we use glob to allow + # us to create a pattern which can ignore the priority value. We + # quote everything in the item to prevent it from being + # glob-matched, exact matching is required. + + proc ::struct::prioqueue::_remove {name item} { + variable queues + set queuelist $queues($name) + set itemrep "* \\[join [split $item {}] "\\"]" + set foundat [lsearch -glob $queuelist $itemrep] + + # the item to remove was not found if foundat remains at -1, + # nothing to replace then + if {$foundat < 0} return + set queues($name) [lreplace $queuelist $foundat $foundat] + return + } +} else { + # 8.5+: We have the -index option, allowing us to exactly address + # the column used to search. + + proc ::struct::prioqueue::_remove {name item} { + variable queues + set queuelist $queues($name) + set foundat [lsearch -index 1 -exact $queuelist $item] + + # the item to remove was not found if foundat remains at -1, + # nothing to replace then + if {$foundat < 0} return + set queues($name) [lreplace $queuelist $foundat $foundat] + return + } +} + +# ::struct::prioqueue::_size -- +# +# Return the number of objects on a queue. +# +# Arguments: +# name name of the queue object. +# +# Results: +# count number of items on the queue. + +proc ::struct::prioqueue::_size {name} { + variable queues + return [llength $queues($name)] +} + +# ::struct::prioqueue::__linsertsorted +# +# Helper proc for inserting into a sorted list. +# +# + +proc ::struct::prioqueue::__linsertsorted {list newElement sortopt sortdir} { + + set cmpcmd __elementcompare${sortopt} + set pos -1 + set newPrio [lindex $newElement 0] + + # do a binary search + set lower -1 + set upper [llength $list] + set bound [expr {$upper+1}] + set pivot 0 + + if {$upper > 0} { + while {$lower +1 != $upper } { + + # get the pivot element + set pivot [expr {($lower + $upper) / 2}] + set element [lindex $list $pivot] + set prio [lindex $element 0] + + # check + set test [$cmpcmd $prio $newPrio $sortdir] + if {$test == 0} { + set pos $pivot + set upper $pivot + # now break as we need the last item + break + } elseif {$test > 0 } { + # search lower section + set upper $pivot + set bound $upper + set pos -1 + } else { + # search upper section + set lower $pivot + set pos $bound + } + } + + + if {$pos == -1} { + # we do an insert before the pivot element + set pos $pivot + } + + # loop to the last matching element to + # keep a stable insertion order + while {[$cmpcmd $prio $newPrio $sortdir]==0} { + incr pos + if {$pos > [llength $list]} {break} + set element [lindex $list $pos] + set prio [lindex $element 0] + } + + } else { + set pos 0 + } + + # do the insert without copying + linsert [K $list [set list ""]] $pos $newElement +} + +# ::struct::prioqueue::__elementcompare +# +# Compare helpers with the sort options. +# +# + +proc ::struct::prioqueue::__elementcompare-integer {prio newPrio sortdir} { + return [expr {$prio < $newPrio ? -1*$sortdir : ($prio != $newPrio)*$sortdir}] +} + +proc ::struct::prioqueue::__elementcompare-real {prio newPrio sortdir} { + return [expr {$prio < $newPrio ? -1*$sortdir : ($prio != $newPrio)*$sortdir}] +} + +proc ::struct::prioqueue::__elementcompare-ascii {prio newPrio sortdir} { + return [expr {[string compare $prio $newPrio]*$sortdir}] +} + +proc ::struct::prioqueue::__elementcompare-dictionary {prio newPrio sortdir} { + # need to use lsort to access -dictionary sorting + set tlist [lsort -increasing -dictionary [list $prio $newPrio]] + set e1 [string equal [lindex $tlist 0] $prio] + set e2 [string equal [lindex $tlist 1] $prio] + return [expr {$e1 > $e2 ? -1*$sortdir : ($e1 != $e2)*$sortdir}] +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'prioqueue::prioqueue' into the general structure namespace. + namespace import -force prioqueue::prioqueue + namespace export prioqueue +} + +package provide struct::prioqueue 1.5 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/queue.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/queue.tcl new file mode 100644 index 00000000..4db75306 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/queue.tcl @@ -0,0 +1,183 @@ +# queue.tcl -- +# +# Implementation of a queue data structure for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2008 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: queue.tcl,v 1.16 2012/11/21 22:36:18 andreas_kupries Exp $ + +# @mdgen EXCLUDE: queue_c.tcl + +package require Tcl 8.5 9 +namespace eval ::struct::queue {} + +# ### ### ### ######### ######### ######### +## Management of queue implementations. + +# ::struct::queue::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::queue::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of queue requires Tcl 8.4. + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::queue_critcl]] + } + tcl { + variable selfdir + if {![catch {package require TclOO 0.6.1-}]} { + source [file join $selfdir queue_oo.tcl] + } else { + source [file join $selfdir queue_tcl.tcl] + } + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::queue::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::queue::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::queue ::struct::queue_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::queue_$key ::struct::queue + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +# ::struct::queue::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::queue::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::queue::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::queue::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::queue::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::queue { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::queue { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export queue +} + +package provide struct::queue 1.4.6 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/queue_c.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/queue_c.tcl new file mode 100644 index 00000000..6d9fb70b --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/queue_c.tcl @@ -0,0 +1,151 @@ +# queuec.tcl -- +# +# Implementation of a queue data structure for Tcl. +# This code based on critcl, API compatible to the PTI [x]. +# [x] Pure Tcl Implementation. +# +# Copyright (c) 2008 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: queue_c.tcl,v 1.2 2011/04/21 17:51:55 andreas_kupries Exp $ + +package require critcl +# @sak notprovided struct_queuec +package provide struct_queuec 1.3.1 +package require Tcl 8.5 9 + +namespace eval ::struct { + # Supporting code for the main command. + + critcl::cheaders queue/*.h + critcl::csources queue/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include + #include + #include + #include + + /* .................................................. */ + /* Global queue management, per interp + */ + + typedef struct QDg { + long int counter; + char buf [50]; + } QDg; + + static void + QDgrelease (ClientData cd, Tcl_Interp* interp) + { + ckfree((char*) cd); + } + + static CONST char* + QDnewName (Tcl_Interp* interp) + { +#define KEY "tcllib/struct::queue/critcl" + + Tcl_InterpDeleteProc* proc = QDgrelease; + QDg* qdg; + + qdg = Tcl_GetAssocData (interp, KEY, &proc); + if (qdg == NULL) { + qdg = (QDg*) ckalloc (sizeof (QDg)); + qdg->counter = 0; + + Tcl_SetAssocData (interp, KEY, proc, + (ClientData) qdg); + } + + qdg->counter ++; + sprintf (qdg->buf, "queue%ld", qdg->counter); + return qdg->buf; + +#undef KEY + } + + static void + QDdeleteCmd (ClientData clientData) + { + /* Release the whole queue. */ + qu_delete ((Q*) clientData); + } + } + + # Main command, queue creation. + + critcl::ccommand queue_critcl {dummy interp objc objv} { + /* Syntax + * - epsilon |1 + * - name |2 + */ + + CONST char* name; + Q* qd; + Tcl_Obj* fqn; + Tcl_CmdInfo ci; + +#define USAGE "?name?" + + if ((objc != 2) && (objc != 1)) { + Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ + return TCL_ERROR; + } + + if (objc < 2) { + name = QDnewName (interp); + } else { + name = Tcl_GetString (objv [1]); + } + + if (!Tcl_StringMatch (name, "::*")) { + /* Relative name. Prefix with current namespace */ + + Tcl_Eval (interp, "namespace current"); + fqn = Tcl_GetObjResult (interp); + fqn = Tcl_DuplicateObj (fqn); + Tcl_IncrRefCount (fqn); + + if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { + Tcl_AppendToObj (fqn, "::", -1); /* OK tcl9 */ + } + Tcl_AppendToObj (fqn, name, -1); /* OK tcl9 */ + } else { + fqn = Tcl_NewStringObj (name, -1); /* OK tcl9 */ + Tcl_IncrRefCount (fqn); + } + Tcl_ResetResult (interp); + + if (Tcl_GetCommandInfo (interp, + Tcl_GetString (fqn), + &ci)) { + Tcl_Obj* err; + + err = Tcl_NewObj (); + Tcl_AppendToObj (err, "command \"", -1); /* OK tcl9 */ + Tcl_AppendObjToObj (err, fqn); + Tcl_AppendToObj (err, "\" already exists, unable to create queue", -1); /* OK tcl9 */ + + Tcl_DecrRefCount (fqn); + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + qd = qu_new(); + qd->cmd = Tcl_CreateObjCommand2 (interp, Tcl_GetString (fqn), + qums_objcmd, (ClientData) qd, + QDdeleteCmd); + + Tcl_SetObjResult (interp, fqn); + Tcl_DecrRefCount (fqn); + return TCL_OK; + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/queue_oo.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/queue_oo.tcl new file mode 100644 index 00000000..c5de5dd4 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/queue_oo.tcl @@ -0,0 +1,228 @@ +# queue.tcl -- +# +# Queue implementation for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2008-2010 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: queue_oo.tcl,v 1.2 2010/09/10 17:31:04 andreas_kupries Exp $ + +package require Tcl 8.5 9 +package require TclOO 0.6.1- ; # This includes 1 and higher. + +# Cleanup first +catch {namespace delete ::struct::queue::queue_oo} +catch {rename ::struct::queue::queue_oo {}} +oo::class create ::struct::queue::queue_oo { + + variable qat qret qadd + + # variable qat - Index in qret of next element to return + # variable qret - List of elements waiting for return + # variable qadd - List of elements added and not yet reached for return. + + constructor {} { + set qat 0 + set qret [list] + set qadd [list] + return + } + + # clear -- + # + # Clear a queue. + # + # Results: + # None. + + method clear {} { + set qat 0 + set qret [list] + set qadd [list] + return + } + + # get -- + # + # Get an item from a queue. + # + # Arguments: + # count number of items to get; defaults to 1 + # + # Results: + # item first count items from the queue; if there are not enough + # items in the queue, throws an error. + + method get {{count 1}} { + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [my size] } { + return -code error "insufficient items in queue to fill request" + } + + my Shift? + + if { $count == 1 } { + # Handle this as a special case, so single item gets aren't + # listified + + set item [lindex $qret $qat] + incr qat + my Shift? + return $item + } + + # Otherwise, return a list of items + + if {$count > ([llength $qret] - $qat)} { + # Need all of qret (from qat on) and parts of qadd, maybe all. + set max [expr {$qat + $count - 1 - [llength $qret]}] + set result [concat [lrange $qret $qat end] [lrange $qadd 0 $max]] + my Shift + set qat $max + } else { + # Request can be satisified from qret alone. + set max [expr {$qat + $count - 1}] + set result [lrange $qret $qat $max] + set qat $max + } + + incr qat + my Shift? + return $result + } + + # peek -- + # + # Retrieve the value of an item on the queue without removing it. + # + # Arguments: + # count number of items to peek; defaults to 1 + # + # Results: + # items top count items from the queue; if there are not enough items + # to fulfill the request, throws an error. + + method peek {{count 1}} { + variable queues + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [my size] } { + return -code error "insufficient items in queue to fill request" + } + + my Shift? + + if { $count == 1 } { + # Handle this as a special case, so single item pops aren't + # listified + return [lindex $qret $qat] + } + + # Otherwise, return a list of items + + if {$count > [llength $qret] - $qat} { + # Need all of qret (from qat on) and parts of qadd, maybe all. + set over [expr {$qat + $count - 1 - [llength $qret]}] + return [concat [lrange $qret $qat end] [lrange $qadd 0 $over]] + } else { + # Request can be satisified from qret alone. + return [lrange $qret $qat [expr {$qat + $count - 1}]] + } + } + + # put -- + # + # Put an item into a queue. + # + # Arguments: + # args items to put. + # + # Results: + # None. + + method put {args} { + if {![llength $args]} { + return -code error "wrong # args: should be \"[self] put item ?item ...?\"" + } + foreach item $args { + lappend qadd $item + } + return + } + + # unget -- + # + # Put an item into a queue. At the _front_! + # + # Arguments: + # item item to put at the front of the queue + # + # Results: + # None. + + method unget {item} { + if {![llength $qret]} { + set qret [list $item] + } elseif {$qat == 0} { + set qret [linsert [my K $qret [unset qret]] 0 $item] + } else { + # step back and modify return buffer + incr qat -1 + set qret [lreplace [my K $qret [unset qret]] $qat $qat $item] + } + return + } + + # size -- + # + # Return the number of objects on a queue. + # + # Results: + # count number of items on the queue. + + method size {} { + return [expr { + [llength $qret] + [llength $qadd] - $qat + }] + } + + # ### ### ### ######### ######### ######### + + method Shift? {} { + if {$qat < [llength $qret]} return + # inlined Shift + set qat 0 + set qret $qadd + set qadd [list] + return + } + + method Shift {} { + set qat 0 + set qret $qadd + set qadd [list] + return + } + + method K {x y} { set x } +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'queue::queue' into the general structure namespace for + # pickup by the main management. + + proc queue_tcl {args} { + if {[llength $args]} { + uplevel 1 [::list ::struct::queue::queue_oo create {*}$args] + } else { + uplevel 1 [::list ::struct::queue::queue_oo new] + } + } +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/queue_tcl.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/queue_tcl.tcl new file mode 100644 index 00000000..9897a62f --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/queue_tcl.tcl @@ -0,0 +1,383 @@ +# queue.tcl -- +# +# Queue implementation for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2008-2010 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: queue_tcl.tcl,v 1.2 2010/03/24 06:13:00 andreas_kupries Exp $ + +namespace eval ::struct::queue { + # counter is used to give a unique name for unnamed queues + variable counter 0 + + # Only export one command, the one used to instantiate a new queue + namespace export queue_tcl +} + +# ::struct::queue::queue_tcl -- +# +# Create a new queue with a given name; if no name is given, use +# queueX, where X is a number. +# +# Arguments: +# name name of the queue; if null, generate one. +# +# Results: +# name name of the queue created + +proc ::struct::queue::queue_tcl {args} { + variable I::qat + variable I::qret + variable I::qadd + variable counter + + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "queue${counter}" + } + 2 { + # Standard call. New empty queue. + set name [lindex $args 0] + } + default { + # Error. + return -code error \ + "wrong # args: should be \"queue ?name?\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + if {[llength [info commands $name]]} { + return -code error \ + "command \"$name\" already exists, unable to create queue" + } + + # Initialize the queue as empty + set qat($name) 0 + set qret($name) [list] + set qadd($name) [list] + + # Create the command to manipulate the queue + interp alias {} $name {} ::struct::queue::QueueProc $name + + return $name +} + +########################## +# Private functions follow + +# ::struct::queue::QueueProc -- +# +# Command that processes all queue object commands. +# +# Arguments: +# name name of the queue object to manipulate. +# args command name and args for the command +# +# Results: +# Varies based on command to perform + +if {[package vsatisfies [package provide Tcl] 8.5 9]} { + # In 8.5+ we can do an ensemble for fast dispatch. + + proc ::struct::queue::QueueProc {name cmd args} { + # Shuffle method to front and then simply run the ensemble. + # Dispatch, argument checking, and error message generation + # are all done in the C-level. + + I $cmd $name {*}$args + } + + namespace eval ::struct::queue::I { + namespace export clear destroy get peek \ + put unget size + namespace ensemble create + } + +} else { + # Before 8.5 we have to code our own dispatch, including error + # checking. + + proc ::struct::queue::QueueProc {name cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + if { [llength [info commands ::struct::queue::I::$cmd]] == 0 } { + set optlist [lsort [info commands ::struct::queue::I::*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + if {($p eq "K") || ($p eq "Shift") || ($p eq "Shift?")} continue + lappend xlist $p + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + + uplevel 1 [linsert $args 0 ::struct::queue::I::$cmd $name] + } +} + +namespace eval ::struct::queue::I { + # The arrays hold all of the queues which were made. + variable qat ; # Index in qret of next element to return + variable qret ; # List of elements waiting for return + variable qadd ; # List of elements added and not yet reached for return. +} + +# ::struct::queue::I::clear -- +# +# Clear a queue. +# +# Arguments: +# name name of the queue object. +# +# Results: +# None. + +proc ::struct::queue::I::clear {name} { + variable qat + variable qret + variable qadd + set qat($name) 0 + set qret($name) [list] + set qadd($name) [list] + return +} + +# ::struct::queue::I::destroy -- +# +# Destroy a queue object by removing it's storage space and +# eliminating it's proc. +# +# Arguments: +# name name of the queue object. +# +# Results: +# None. + +proc ::struct::queue::I::destroy {name} { + variable qat ; unset qat($name) + variable qret ; unset qret($name) + variable qadd ; unset qadd($name) + interp alias {} $name {} + return +} + +# ::struct::queue::I::get -- +# +# Get an item from a queue. +# +# Arguments: +# name name of the queue object. +# count number of items to get; defaults to 1 +# +# Results: +# item first count items from the queue; if there are not enough +# items in the queue, throws an error. + +proc ::struct::queue::I::get {name {count 1}} { + if { $count < 1 } { + error "invalid item count $count" + } elseif { $count > [size $name] } { + error "insufficient items in queue to fill request" + } + + Shift? $name + + variable qat ; upvar 0 qat($name) AT + variable qret ; upvar 0 qret($name) RET + variable qadd ; upvar 0 qadd($name) ADD + + if { $count == 1 } { + # Handle this as a special case, so single item gets aren't + # listified + + set item [lindex $RET $AT] + incr AT + Shift? $name + return $item + } + + # Otherwise, return a list of items + + if {$count > ([llength $RET] - $AT)} { + # Need all of RET (from AT on) and parts of ADD, maybe all. + set max [expr {$count - ([llength $RET] - $AT) - 1}] + set result [concat [lrange $RET $AT end] [lrange $ADD 0 $max]] + Shift $name + set AT $max + } else { + # Request can be satisified from RET alone. + set max [expr {$AT + $count - 1}] + set result [lrange $RET $AT $max] + set AT $max + } + + incr AT + Shift? $name + return $result +} + +# ::struct::queue::I::peek -- +# +# Retrieve the value of an item on the queue without removing it. +# +# Arguments: +# name name of the queue object. +# count number of items to peek; defaults to 1 +# +# Results: +# items top count items from the queue; if there are not enough items +# to fulfill the request, throws an error. + +proc ::struct::queue::I::peek {name {count 1}} { + variable queues + if { $count < 1 } { + error "invalid item count $count" + } elseif { $count > [size $name] } { + error "insufficient items in queue to fill request" + } + + Shift? $name + + variable qat ; upvar 0 qat($name) AT + variable qret ; upvar 0 qret($name) RET + variable qadd ; upvar 0 qadd($name) ADD + + if { $count == 1 } { + # Handle this as a special case, so single item pops aren't + # listified + return [lindex $RET $AT] + } + + # Otherwise, return a list of items + + if {$count > [llength $RET] - $AT} { + # Need all of RET (from AT on) and parts of ADD, maybe all. + set over [expr {$count - ([llength $RET] - $AT) - 1}] + return [concat [lrange $RET $AT end] [lrange $ADD 0 $over]] + } else { + # Request can be satisified from RET alone. + return [lrange $RET $AT [expr {$AT + $count - 1}]] + } +} + +# ::struct::queue::I::put -- +# +# Put an item into a queue. +# +# Arguments: +# name name of the queue object +# args items to put. +# +# Results: +# None. + +proc ::struct::queue::I::put {name args} { + variable qadd + if { [llength $args] == 0 } { + error "wrong # args: should be \"$name put item ?item ...?\"" + } + foreach item $args { + lappend qadd($name) $item + } + return +} + +# ::struct::queue::I::unget -- +# +# Put an item into a queue. At the _front_! +# +# Arguments: +# name name of the queue object +# item item to put at the front of the queue +# +# Results: +# None. + +proc ::struct::queue::I::unget {name item} { + variable qat ; upvar 0 qat($name) AT + variable qret ; upvar 0 qret($name) RET + + if {![llength $RET]} { + set RET [list $item] + } elseif {$AT == 0} { + set RET [linsert [K $RET [unset RET]] 0 $item] + } else { + # step back and modify return buffer + incr AT -1 + set RET [lreplace [K $RET [unset RET]] $AT $AT $item] + } + return +} + +# ::struct::queue::I::size -- +# +# Return the number of objects on a queue. +# +# Arguments: +# name name of the queue object. +# +# Results: +# count number of items on the queue. + +proc ::struct::queue::I::size {name} { + variable qat + variable qret + variable qadd + return [expr { + [llength $qret($name)] + [llength $qadd($name)] - $qat($name) + }] +} + +# ### ### ### ######### ######### ######### + +proc ::struct::queue::I::Shift? {name} { + variable qat + variable qret + if {$qat($name) < [llength $qret($name)]} return + Shift $name + return +} + +proc ::struct::queue::I::Shift {name} { + variable qat + variable qret + variable qadd + set qat($name) 0 + set qret($name) $qadd($name) + set qadd($name) [list] + return +} + +proc ::struct::queue::I::K {x y} { set x } + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'queue::queue' into the general structure namespace for + # pickup by the main management. + namespace import -force queue::queue_tcl +} + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/record.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/record.tcl new file mode 100644 index 00000000..20bd073d --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/record.tcl @@ -0,0 +1,830 @@ +#============================================================ +# ::struct::record -- +# +# Implements a container data structure similar to a 'C' +# structure. It hides the ugly details about keeping the +# data organized by using a combination of arrays, lists +# and namespaces. +# +# Each record definition is kept in a master array +# (_recorddefn) under the ::struct::record namespace. Each +# instance of a record is kept within a separate namespace +# for each record definition. Hence, instances of +# the same record definition are managed under the +# same namespace. This avoids possible collisions, and +# also limits one big global array mechanism. +# +# Copyright (c) 2002 by Brett Schwarz +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# This code may be distributed under the same terms as Tcl. +# +#============================================================ +# +#### FIX ERROR MESSAGES SO THEY MAKE SENSE (Wrong args) + +namespace eval ::struct {} + +namespace eval ::struct::record { + + ## + ## array of lists that holds the definition (variables) for each + ## record + ## + ## _recorddefn(some_record) var1 var2 var3 ... + ## + variable _recorddefn + + ## + ## holds the count for each record in cases where the instance is + ## automatically generated + ## + ## _count(some_record) 0 + ## + + ## This is not a count, but an id generator. Its value has to + ## increase monotonicaly. + + variable _count + + ## + ## array that holds the defining record's name for each instances + ## + ## _defn(some_instances) name_of_defining_record + ## + variable _defn + array set _defn {} + + ## + ## This holds the defaults for a record definition. If no + ## default is given for a member of a record, then the value is + ## assigned to the empty string + ## + variable _defaults + + ## + ## These are the possible sub commands + ## + variable commands + set commands [list define delete exists show] + + ## + ## This keeps track of the level that we are in when handling + ## nested records. This is kind of a hack, and probably can be + ## handled better + ## + set _level 0 + + namespace export record +} + +#------------------------------------------------------------ +# ::struct::record::record -- +# +# main command used to access the other sub commands +# +# Arguments: +# cmd_ The sub command (i.e. define, show, delete, exists) +# args arguments to pass to the sub command +# +# Results: +# none returned +#------------------------------------------------------------ +# +proc ::struct::record::record {cmd_ args} { + variable commands + + if {[lsearch $commands $cmd_] < 0} { + error "Sub command \"$cmd_\" is not recognized. Must be [join $commands ,]" + } + + set cmd_ [string totitle "$cmd_"] + return [uplevel 1 ::struct::record::${cmd_} $args] + +}; # end proc ::struct::record::record + + +#------------------------------------------------------------ +# ::struct::record::Define -- +# +# Used to define a record +# +# Arguments: +# defn_ the name of the record definition +# vars_ the variables of the record (as a list) +# args instances to be create during definition +# +# Results: +# Returns the name of the definition during successful +# creation. +#------------------------------------------------------------ +# +proc ::struct::record::Define {defn_ vars_ args} { + variable _recorddefn + variable _count + variable _defaults + + # puts .([info level 0])... + + set defn_ [Qualify $defn_] + + if {[info exists _recorddefn($defn_)]} { + error "Record definition $defn_ already exists" + } + + if {[lsearch [info commands] $defn_] >= 0} { + error "Structure definition name can not be a Tcl command name" + } + + set _defaults($defn_) [list] + set _recorddefn($defn_) [list] + + ## + ## Loop through the members of the record + ## definition + ## + foreach V $vars_ { + set len [llength $V] + set D "" + + if {$len == 2} { + ## 2 --> there is a default value + ## assigned to the member + + set D [lindex $V 1] + set V [lindex $V 0] + + } elseif {$len == 3} { + ## 3 --> there is a nested record + ## definition given as a member + ## V = ('record' record-name field-name) + + if {![string match "record" "[lindex $V 0]"]} { + Delete record $defn_ + error "$V is a Bad member for record definition. Definition creation aborted." + } + + set new [lindex $V 1] + set new [Qualify $new] + # puts .\tchild=$new + ## + ## Right now, there can not be circular records + ## so, we abort the creation + ## + if {[string match "$defn_" "$new"]} { + # puts .\tabort + Delete record $defn_ + error "Can not have circular records. Structure was not created." + } + + ## + ## Will take care of the nested record later + ## We just join by :: because this is how it + ## use to be declared, so the parsing code + ## is already there. + ## + set V [join [lrange $V 1 2] "::"] + } + + # puts .\tfield($V)=default($D) + + lappend _recorddefn($defn_) $V + lappend _defaults($defn_) $D + } + + # Create class command as alias to instance creator. + uplevel #0 [list interp alias \ + {} $defn_ \ + {} ::struct::record::Create $defn_] + + set _count($defn_) 0 + + # Create class namespace. This will hold all the instance information. + namespace eval ::struct::record${defn_} { + variable values + variable instances + variable record + + set instances [list] + } + + set ::struct::record${defn_}::record $defn_ + + ## + ## If there were args given (instances), then + ## create them now + ## + foreach A $args { + uplevel 1 [list ::struct::record::Create $defn_ $A] + } + + # puts .=>${defn_} + return $defn_ + +}; # end proc ::struct::record::Define + + +#------------------------------------------------------------ +# ::struct::record::Create -- +# +# Creates an instance of a record definition +# +# Arguments: +# defn_ the name of the record definition +# inst_ the name of the instances to create +# args values to set to the record's members +# +# Results: +# Returns the name of the instance for a successful creation +#------------------------------------------------------------ +# +proc ::struct::record::Create {defn_ inst_ args} { + variable _recorddefn + variable _count + variable _defn + variable _defaults + variable _level + + # puts .([info level 0])... + + set inst_ [Qualify "$inst_"] + + ## + ## test to see if the record + ## definition has been defined yet + ## + if {![info exists _recorddefn($defn_)]} { + error "Structure $defn_ does not exist" + } + + ## + ## if there was no argument given, + ## then assume that the record + ## variable is automatically + ## generated + ## + if {[string match "[Qualify #auto]" "$inst_"]} { + set c $_count($defn_) + set inst_ [format "%s%s" ${defn_} $_count($defn_)] + incr _count($defn_) + } + + ## + ## Test to see if this instance is already + ## created. This avoids any collisions with + ## previously created instances + ## + if {[info exists _defn($inst_)]} { + incr _count($defn_) -1 + error "Instances $inst_ already exists" + } + + set _defn($inst_) $defn_ + + ## + ## Initialize record variables to defaults + ## + + # Create instance command as alias of instance dispatcher. + uplevel #0 [list interp alias {} ${inst_} {} ::struct::record::Cmd $inst_] + + # Locate manager namespace, i.e. class namespace for new instance + set nsi [Ns $inst_] + # puts .\tnsi=$nsi + + # Import the state of the manager namespace + upvar 0 ${nsi}values __values + upvar 0 ${nsi}instances __instances + + set cnt 0 + foreach V $_recorddefn($defn_) D $_defaults($defn_) { + + # puts .\tfield($V)=default($D) + + set __values($inst_,$V) $D + + ## + ## Test to see if there is a nested record + ## + if {[regexp -- {([\w]*)::([\w]*)} $V -> def inst]} { + + if {$_level == 0} { + set _level 2 + } + + ## + ## This is to guard against if the creation had failed, + ## that there isn't any lingering variables/alias around + ## + set def [Qualify $def $_level] + + if {![info exists _recorddefn($def)]} { + Delete inst "$inst_" + return + } + + ## + ## evaluate the nested record. If there were values for + ## the variables passed in, then we assume that the + ## value for this nested record is a list corresponding + ## the the nested list's variables, and so we pass that + ## to the nested record's instantiation. We then get + ## rid of those args for later processing. + ## + set cnt_plus [expr {$cnt + 1}] + set mem [lindex $args $cnt] + if {![string match "" "$mem"]} { + if {![string match "-$inst" "$mem"]} { + Delete inst "$inst_" + error "$inst is not a member of $defn_" + } + } + incr _level + set narg [lindex $args $cnt_plus] + + # Create instance of the nested record. + eval [linsert $narg 0 Create $def ${inst_}.${inst}] + + set args [lreplace $args $cnt $cnt_plus] + + incr _level -1 + } else { + # Regular field, not a nested record. Create alias for + # field access. + uplevel #0 [list interp alias \ + {} ${inst_}.$V \ + {} ::struct::record::Access $defn_ $inst_ $V] + incr cnt 2 + } + }; # end foreach variable + + # Remember new instance. + lappend __instances $inst_ + + # Apply field values handed to the instance constructor. + foreach {k v} $args { + Access $defn_ $inst_ [string trimleft "$k" -] $v + }; # end foreach arg {} + + if {$_level == 2} { + set _level 0 + } + + # puts .=>${inst_} + return $inst_ + +}; # end proc ::struct::record::Create + + +#------------------------------------------------------------ +# ::struct::record::Access -- +# +# Provides a common proc to access the variables +# from the aliases create for each variable in the record +# +# Arguments: +# defn_ the name of the record to access +# inst_ the name of the instance to create +# var_ the variable of the record to access +# args a value to set to var_ (if any) +# +# Results: +# Returns the value of the record member (var_) +#------------------------------------------------------------ +# +proc ::struct::record::Access {defn_ inst_ var_ args} { + + variable _recorddefn + variable _defn + + set i [lsearch $_recorddefn($defn_) $var_] + + if {$i < 0} { + error "$var_ does not exist in record $defn_" + } + + if {![info exists _defn($inst_)]} { + + error "$inst_ does not exist" + } + + if {[set idx [lsearch $args "="]] >= 0} { + set args [lreplace $args $idx $idx] + } + + set nsi [Ns $inst_] + # puts .\tnsi=$nsi + + # Import the state of the manager namespace + upvar 0 ${nsi}values __values + + ## + ## If a value was given, then set it + ## + if {[llength $args] != 0} { + + set val_ [lindex $args 0] + + set __values($inst_,$var_) $val_ + } + + return $__values($inst_,$var_) + +}; # end proc ::struct::record::Access + + +#------------------------------------------------------------ +# ::struct::record::Cmd -- +# +# Used to process the set/get requests. +# +# Arguments: +# inst_ the record instance name +# args For 'get' this is the record members to +# retrieve. For 'set' this is a member/value +# pair. +# +# Results: +# For 'set' returns the empty string. For 'get' it returns +# the member values. +#------------------------------------------------------------ +# +proc ::struct::record::Cmd {inst_ args} { + + variable _defn + + set result [list] + + set len [llength $args] + if {$len <= 1} {return [Show values "$inst_"]} + + set cmd [lindex $args 0] + + if {[string match "cget" "$cmd"]} { + + set cnt 0 + foreach k [lrange $args 1 end] { + if {[catch {set r [${inst_}.[string trimleft ${k} -]]} err]} { + error "Bad option \"$k\"" + } + + lappend result $r + incr cnt + } + if {$cnt == 1} {set result [lindex $result 0]} + return $result + + } elseif {[string match "config*" "$cmd"]} { + + set L [lrange $args 1 end] + foreach {k v} $L { + ${inst_}.[string trimleft ${k} -] $v + } + + } else { + error "Wrong argument. + must be \"object cget|configure args\"" + } + + return [list] + +}; # end proc ::struct::record::Cmd + + +#------------------------------------------------------------ +# ::struct::record::Ns -- +# +# This just constructs a fully qualified namespace for a +# particular instance. +# +# Arguments; +# inst_ instance to construct the namespace for. +# +# Results: +# Returns the fully qualified namespace for the instance +#------------------------------------------------------------ +# +proc ::struct::record::Ns {inst_} { + + variable _defn + + if {[catch {set ret $_defn($inst_)} err]} { + return $inst_ + } + + return [format "%s%s%s" "::struct::record" $ret "::"] + +}; # end proc ::struct::record::Ns + + +#------------------------------------------------------------ +# ::struct::record::Show -- +# +# Display info about the record that exist +# +# Arguments: +# what_ subcommand +# record_ record or instance to process +# +# Results: +# if what_ = record, then return list of records +# definition names. +# if what_ = members, then return list of members +# or members of the record. +# if what_ = instance, then return a list of instances +# with record definition of record_ +# if what_ = values, then it will return the values +# for a particular instance +#------------------------------------------------------------ +# +proc ::struct::record::Show {what_ {record_ ""}} { + variable _recorddefn + variable _defn + variable _defaults + + set record_ [Qualify $record_] + + ## + ## We just prepend :: to the record_ argument + ## + #if {![string match "::*" "$record_"]} {set record_ "::$record_"} + + if {[string match "record*" "$what_"]} { + # Show record + + return [lsort [array names _recorddefn]] + } + + if {[string match "mem*" "$what_"]} { + # Show members + + if {[string match "" "$record_"] || ![info exists _recorddefn($record_)]} { + error "Bad arguments while accessing members. Bad record name" + } + + set res [list] + set cnt 0 + foreach m $_recorddefn($record_) { + set def [lindex $_defaults($record_) $cnt] + if {[regexp -- {([\w]+)::([\w]+)} $m m d i]} { + lappend res [list record $d $i] + } elseif {![string match "" "$def"]} { + lappend res [list $m $def] + } else { + lappend res $m + } + + incr cnt + } + + return $res + } + + if {[string match "inst*" "$what_"]} { + # Show instances + + if {![namespace exists ::struct::record${record_}]} { + return [list] + } + + # Import the state of the manager namespace + upvar 0 ::struct::record${record_}::instances __instances + + if {![info exists __instances]} { + return [list] + } + return [lsort $__instances] + + } + + if {[string match "val*" "$what_"]} { + # Show values + + set nsi [Ns $record_] + upvar 0 ${nsi}::instances __instances + upvar 0 ${nsi}::values __values + upvar 0 ${nsi}::record __record + + if {[string match "" "$record_"] || + ([lsearch $__instances $record_] < 0)} { + + error "Wrong arguments to values. Bad instance name" + } + + set ret [list] + foreach k $_recorddefn($__record) { + set v $__values($record_,$k) + + if {[regexp -- {([\w]*)::([\w]*)} $k m def inst]} { + set v [::struct::record::Show values ${record_}.${inst}] + } + + lappend ret -[namespace tail $k] $v + } + return $ret + + } + + # Bogus submethod + return [list] + +}; # end proc ::struct::record::Show + + +#------------------------------------------------------------ +# ::struct::record::Delete -- +# +# Deletes a record instance or a record definition +# +# Arguments: +# sub_ what to delete. Either 'instance' or 'record' +# item_ the specific record instance or definition +# delete. +# +# Returns: +# none +# +#------------------------------------------------------------ +# +proc ::struct::record::Delete {sub_ item_} { + variable _recorddefn + variable _defn + variable _count + variable _defaults + + # puts .([info level 0])... + + set item_ [Qualify $item_] + + switch -- $sub_ { + instance - + instances - + inst { + # puts .instance + # puts .is-instance=[Exists instance $item_] + + if {[Exists instance $item_]} { + + # Locate manager namespace, i.e. class namespace for + # instance to remove + set nsi [Ns $item_] + # puts .\tnsi=$nsi + + # Import the state of the manager namespace + upvar 0 ${nsi}values __values + upvar 0 ${nsi}instances __instances + upvar 0 ${nsi}record __record + # puts .\trecord=$__record + + # Remove instance from state + set i [lsearch $__instances $item_] + set __instances [lreplace $__instances $i $i] + unset _defn($item_) + + # Process instance fields. + + foreach V $_recorddefn($__record) { + # puts .\tfield($V)=/clear + + if {[regexp -- {([\w]*)::([\w]*)} $V m def inst]} { + # Nested record detected. + # Determine associated instance and delete recursively. + Delete inst ${item_}.${inst} + } else { + # Delete field accessor alias + # puts .de-alias\t($item_.$V) + uplevel #0 [list interp alias {} ${item_}.$V {}] + } + + unset __values($item_,$V) + } + + # Auto-generated id numbers increase monotonically. + # Reverting here causes the next auto to fail, claiming + # that the instance exists. + # incr _count($ns) -1 + + } else { + #error "$item_ is not a instance" + } + } + record - + records { + # puts .record + ## + ## Delete the instances for this + ## record + ## + # puts .get-instances + foreach I [Show instance "$item_"] { + catch { + # puts .di/$I + Delete instance "$I" + } + } + + catch { + unset _recorddefn($item_) + unset _defaults($item_) + unset _count($item_) + namespace delete ::struct::record${item_} + } + } + default { + error "Wrong arguments to delete" + } + + }; # end switch + + # Remove alias associated with instance or record (class) + # puts .de-alias\t($item_) + catch { uplevel #0 [list interp alias {} $item_ {}]} + + # puts ./ + return + +}; # end proc ::struct::record::Delete + + +#------------------------------------------------------------ +# ::struct::record::Exists -- +# +# Tests whether a record definition or record +# instance exists. +# +# Arguments: +# sub_ what to test. Either 'instance' or 'record' +# item_ the specific record instance or definition +# that needs to be tested. +# +# Tests to see if a particular instance exists +# +#------------------------------------------------------------ +# +proc ::struct::record::Exists {sub_ item_} { + + # puts .([info level 0])... + + set item_ [Qualify $item_] + + switch -glob -- $sub_ { + inst* { + variable _defn + return [info exists _defn($item_)] + } + record { + variable _recorddefn + return [info exists _recorddefn($item_)] + } + default { + error "Wrong arguments. Must be exists record|instance target" + } + }; # end switch + +}; # end proc ::struct::record::Exists + + +#------------------------------------------------------------ +# ::struct::record::Qualify -- +# +# Contructs the qualified name of the calling scope. This +# defaults to 2 levels since there is an extra proc call in +# between. +# +# Arguments: +# item_ the command that needs to be qualified +# level_ how many levels to go up (default = 2) +# +# Results: +# the item_ passed in fully qualified +# +#------------------------------------------------------------ +# +proc ::struct::record::Qualify {item_ {level_ 2}} { + if {![string match "::*" "$item_"]} { + set ns [uplevel $level_ [list namespace current]] + + if {![string match "::" "$ns"]} { + append ns "::" + } + + set item_ "$ns${item_}" + } + + return "$item_" + +}; # end proc ::struct::record::Qualify + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'record::record' into the general structure namespace. + namespace import -force record::record + namespace export record +} + +package provide struct::record 1.2.3 +return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/sets.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/sets.tcl new file mode 100644 index 00000000..f6fdd0d4 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/sets.tcl @@ -0,0 +1,187 @@ +#---------------------------------------------------------------------- +# +# sets.tcl -- +# +# Definitions for the processing of sets. +# +# Copyright (c) 2004-2008 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ +# +#---------------------------------------------------------------------- + +# @mdgen EXCLUDE: sets_c.tcl + +package require Tcl 8.5 9 + +namespace eval ::struct::set {} + +# ### ### ### ######### ######### ######### +## Management of set implementations. + +# ::struct::set::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::set::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::set_critcl]] + } + tcl { + variable selfdir + source [file join $selfdir sets_tcl.tcl] + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::set::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::set::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::set ::struct::set_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::set_$key ::struct::set + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +proc ::struct::set::Loaded {} { + variable loaded + return $loaded +} + +# ::struct::set::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::set::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::set::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::set::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::set::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::set { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::set { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export set +} + +package provide struct::set 2.2.4 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/sets_c.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/sets_c.tcl new file mode 100644 index 00000000..9c4fb76c --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/sets_c.tcl @@ -0,0 +1,91 @@ +#---------------------------------------------------------------------- +# +# sets_tcl.tcl -- +# +# Definitions for the processing of sets. C implementation. +# +# Copyright (c) 2007 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +#---------------------------------------------------------------------- + +package require critcl +# @sak notprovided struct_setc +package provide struct_setc 2.1.1 +package require Tcl 8.5 9 + +namespace eval ::struct { + # Supporting code for the main command. + + catch { + #critcl::cheaders -g + #critcl::debug memory symbols + } + + critcl::cheaders sets/*.h + critcl::csources sets/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include + } + + # Main command, set creation. + + critcl::ccommand set_critcl {dummy interp objc objv} { + /* Syntax - dispatcher to the sub commands. + */ + + static CONST char* methods [] = { + "add", "contains", "difference", "empty", + "equal","exclude", "include", "intersect", + "intersect3", "size", "subsetof", "subtract", + "symdiff", "union", + NULL + }; + enum methods { + S_add, S_contains, S_difference, S_empty, + S_equal,S_exclude, S_include, S_intersect, + S_intersect3, S_size, S_subsetof, S_subtract, + S_symdiff, S_union + }; + + int m; + + if (objc < 2) { + Tcl_WrongNumArgs (interp, objc, objv, "cmd ?arg ...?"); /* OK tcl9 */ + return TCL_ERROR; + } else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", + 0, &m) != TCL_OK) { + return TCL_ERROR; + } + + /* Dispatch to methods. They check the #args in detail before performing + * the requested functionality + */ + + switch (m) { + case S_add: return sm_ADD (NULL, interp, objc, objv); + case S_contains: return sm_CONTAINS (NULL, interp, objc, objv); + case S_difference: return sm_DIFFERENCE (NULL, interp, objc, objv); + case S_empty: return sm_EMPTY (NULL, interp, objc, objv); + case S_equal: return sm_EQUAL (NULL, interp, objc, objv); + case S_exclude: return sm_EXCLUDE (NULL, interp, objc, objv); + case S_include: return sm_INCLUDE (NULL, interp, objc, objv); + case S_intersect: return sm_INTERSECT (NULL, interp, objc, objv); + case S_intersect3: return sm_INTERSECT3 (NULL, interp, objc, objv); + case S_size: return sm_SIZE (NULL, interp, objc, objv); + case S_subsetof: return sm_SUBSETOF (NULL, interp, objc, objv); + case S_subtract: return sm_SUBTRACT (NULL, interp, objc, objv); + case S_symdiff: return sm_SYMDIFF (NULL, interp, objc, objv); + case S_union: return sm_UNION (NULL, interp, objc, objv); + } + /* Not coming to this place */ + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/sets_tcl.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/sets_tcl.tcl new file mode 100644 index 00000000..2dcc5902 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/sets_tcl.tcl @@ -0,0 +1,452 @@ +#---------------------------------------------------------------------- +# +# sets_tcl.tcl -- +# +# Definitions for the processing of sets. +# +# Copyright (c) 2004-2008 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: sets_tcl.tcl,v 1.4 2008/03/09 04:38:47 andreas_kupries Exp $ +# +#---------------------------------------------------------------------- + +package require Tcl 8.5 9 + +namespace eval ::struct::set { + # Only export one command, the one used to instantiate a new tree + namespace export set_tcl +} + +########################## +# Public functions + +# ::struct::set::set -- +# +# Command that access all set commands. +# +# Arguments: +# cmd Name of the subcommand to dispatch to. +# args Arguments for the subcommand. +# +# Results: +# Whatever the result of the subcommand is. + +proc ::struct::set::set_tcl {cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 1 } { + return -code error "wrong # args: should be \"$cmd ?arg arg ...?\"" + } + ::set sub S_$cmd + if { [llength [info commands ::struct::set::$sub]] == 0 } { + ::set optlist [info commands ::struct::set::S_*] + ::set xlist {} + foreach p $optlist { + lappend xlist [string range $p 17 end] + } + return -code error \ + "bad option \"$cmd\": must be [linsert [join [lsort $xlist] ", "] "end-1" "or"]" + } + return [uplevel 1 [linsert $args 0 ::struct::set::$sub]] +} + +########################## +# Implementations of the functionality. +# + +# ::struct::set::S_empty -- +# +# Determines emptiness of the set +# +# Parameters: +# set -- The set to check for emptiness. +# +# Results: +# A boolean value. True indicates that the set is empty. +# +# Side effects: +# None. +# +# Notes: + +proc ::struct::set::S_empty {set} { + return [expr {[llength $set] == 0}] +} + +# ::struct::set::S_size -- +# +# Computes the cardinality of the set. +# +# Parameters: +# set -- The set to inspect. +# +# Results: +# An integer greater than or equal to zero. +# +# Side effects: +# None. + +proc ::struct::set::S_size {set} { + return [llength [Cleanup $set]] +} + +# ::struct::set::S_contains -- +# +# Determines if the item is in the set. +# +# Parameters: +# set -- The set to inspect. +# item -- The element to look for. +# +# Results: +# A boolean value. True indicates that the element is present. +# +# Side effects: +# None. + +proc ::struct::set::S_contains {set item} { + return [expr {[lsearch -exact $set $item] >= 0}] +} + +# ::struct::set::S_union -- +# +# Computes the union of the arguments. +# +# Parameters: +# args -- List of sets to unify. +# +# Results: +# The union of the arguments. +# +# Side effects: +# None. + +proc ::struct::set::S_union {args} { + switch -exact -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + } + foreach setX $args { + foreach x $setX {::set ($x) {}} + } + return [array names {}] +} + + +# ::struct::set::S_intersect -- +# +# Computes the intersection of the arguments. +# +# Parameters: +# args -- List of sets to intersect. +# +# Results: +# The intersection of the arguments +# +# Side effects: +# None. + +proc ::struct::set::S_intersect {args} { + switch -exact -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + } + ::set res [lindex $args 0] + foreach set [lrange $args 1 end] { + if {[llength $res] && [llength $set]} { + ::set res [Intersect $res $set] + } else { + # Squash 'res'. Otherwise we get the wrong result if res + # is not empty, but 'set' is. + ::set res {} + break + } + } + return $res +} + +proc ::struct::set::Intersect {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return {}} + + # This is slower than local vars, but more robust + 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 +} + +# ::struct::set::S_difference -- +# +# Compute difference of two sets. +# +# Parameters: +# A, B -- Sets to compute the difference for. +# +# Results: +# A - B +# +# Side effects: +# None. + +proc ::struct::set::S_difference {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return $A} + + array set tmp {} + foreach x $A {::set tmp($x) .} + foreach x $B {catch {unset tmp($x)}} + return [array names tmp] +} + +if {0} { + # Tcllib SF Bug 1002143. We cannot use the implementation below. + # It will treat set elements containing '(' and ')' as array + # elements, and this screws up the storage of elements as the name + # of local vars something fierce. No way around this. Disabling + # this code and always using the other implementation (s.a.) is + # the only possible fix. + + if {[package vcompare [package provide Tcl] 8.4] < 0} { + # Tcl 8.[23]. Use explicit array to perform the operation. + } else { + # Tcl 8.4+, has 'unset -nocomplain' + + proc ::struct::set::S_difference {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return $A} + + # Get the variable B out of the way, avoid collisions + # prepare for "pure list optimization" + ::set ::struct::set::tmp [lreplace $B -1 -1 unset -nocomplain] + unset B + + # unset A early: no local variables left + foreach [lindex [list $A [unset A]] 0] {.} {break} + + eval $::struct::set::tmp + return [info locals] + } + } +} + +# ::struct::set::S_symdiff -- +# +# Compute symmetric difference of two sets. +# +# Parameters: +# A, B -- The sets to compute the s.difference for. +# +# Results: +# The symmetric difference of the two input sets. +# +# Side effects: +# None. + +proc ::struct::set::S_symdiff {A B} { + # symdiff == (A-B) + (B-A) == (A+B)-(A*B) + if {[llength $A] == 0} {return $B} + if {[llength $B] == 0} {return $A} + return [S_union \ + [S_difference $A $B] \ + [S_difference $B $A]] +} + +# ::struct::set::S_intersect3 -- +# +# Return intersection and differences for two sets. +# +# Parameters: +# A, B -- The sets to inspect. +# +# Results: +# List containing A*B, A-B, and B-A +# +# Side effects: +# None. + +proc ::struct::set::S_intersect3 {A B} { + return [list \ + [S_intersect $A $B] \ + [S_difference $A $B] \ + [S_difference $B $A]] +} + +# ::struct::set::S_equal -- +# +# Compares two sets for equality. +# +# Parameters: +# a First set to compare. +# b Second set to compare. +# +# Results: +# A boolean. True if the lists are equal. +# +# Side effects: +# None. + +proc ::struct::set::S_equal {A B} { + ::set A [Cleanup $A] + ::set B [Cleanup $B] + + # Equal if of same cardinality and difference is empty. + + if {[::llength $A] != [::llength $B]} {return 0} + return [expr {[llength [S_difference $A $B]] == 0}] +} + + +proc ::struct::set::Cleanup {A} { + # unset A to avoid collisions + if {[llength $A] < 2} {return $A} + # We cannot use variables to avoid an explicit array. The set + # elements may look like namespace vars (i.e. contain ::), and + # such elements break that, cannot be proc-local variables. + array set S {} + foreach item $A {set S($item) .} + return [array names S] +} + +# ::struct::set::S_include -- +# +# Add an element to a set. +# +# Parameters: +# Avar -- Reference to the set variable to extend. +# element -- The item to add to the set. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is extended +# by the element (if the element was not already present). + +proc ::struct::set::S_include {Avar element} { + # Avar = Avar + {element} + upvar 1 $Avar A + if {![info exists A] || ![S_contains $A $element]} { + lappend A $element + } + return +} + +# ::struct::set::S_exclude -- +# +# Remove an element from a set. +# +# Parameters: +# Avar -- Reference to the set variable to shrink. +# element -- The item to remove from the set. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is shrunk, +# the element remove (if the element was actually present). + +proc ::struct::set::S_exclude {Avar element} { + # Avar = Avar - {element} + upvar 1 $Avar A + if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} + while {[::set pos [lsearch -exact $A $element]] >= 0} { + ::set A [lreplace [K $A [::set A {}]] $pos $pos] + } + return +} + +# ::struct::set::S_add -- +# +# Add a set to a set. Similar to 'union', but the first argument +# is a variable. +# +# Parameters: +# Avar -- Reference to the set variable to extend. +# B -- The set to add to the set in Avar. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is extended +# by all the elements in B. + +proc ::struct::set::S_add {Avar B} { + # Avar = Avar + B + upvar 1 $Avar A + if {![info exists A]} {set A {}} + ::set A [S_union [K $A [::set A {}]] $B] + return +} + +# ::struct::set::S_subtract -- +# +# Remove a set from a set. Similar to 'difference', but the first argument +# is a variable. +# +# Parameters: +# Avar -- Reference to the set variable to shrink. +# B -- The set to remove from the set in Avar. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is shrunk, +# all elements of B are removed. + +proc ::struct::set::S_subtract {Avar B} { + # Avar = Avar - B + upvar 1 $Avar A + if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} + ::set A [S_difference [K $A [::set A {}]] $B] + return +} + +# ::struct::set::S_subsetof -- +# +# A predicate checking if the first set is a subset +# or equal to the second set. +# +# Parameters: +# A -- The possible subset. +# B -- The set to compare to. +# +# Results: +# A boolean value, true if A is subset of or equal to B +# +# Side effects: +# None. + +proc ::struct::set::S_subsetof {A B} { + # A subset|== B <=> (A == A*B) + return [S_equal $A [S_intersect $A $B]] +} + +# ::struct::set::K -- +# Performance helper command. + +proc ::struct::set::K {x y} {::set x} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Put 'set::set' into the general structure namespace + # for pickup by the main management. + + namespace import -force set::set_tcl +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/skiplist.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/skiplist.tcl new file mode 100644 index 00000000..169ba5c3 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/skiplist.tcl @@ -0,0 +1,437 @@ +# skiplist.tcl -- +# +# Implementation of a skiplist data structure for Tcl. +# +# To quote the inventor of skip lists, William Pugh: +# Skip lists are a probabilistic data structure that seem likely +# to supplant balanced trees as the implementation method of +# choice for many applications. Skip list algorithms have the +# same asymptotic expected time bounds as balanced trees and are +# simpler, faster and use less space. +# +# For more details on how skip lists work, see Pugh, William. Skip +# lists: a probabilistic alternative to balanced trees in +# Communications of the ACM, June 1990, 33(6) 668-676. Also, see +# ftp://ftp.cs.umd.edu/pub/skipLists/ +# +# Copyright (c) 2000 by Keith Vetter +# This software is licensed under a BSD license as described in tcl/tk +# license.txt file but with the copyright held by Keith Vetter. +# +# TODO: +# customize key comparison to a user supplied routine + +namespace eval ::struct {} + +namespace eval ::struct::skiplist { + # Data storage in the skiplist module + # ------------------------------- + # + # For each skiplist, we have the following arrays + # state - holds the current level plus some magic constants + # nodes - all the nodes in the skiplist, including a dummy header node + + # counter is used to give a unique name for unnamed skiplists + variable counter 0 + + # Internal constants + variable MAXLEVEL 16 + variable PROB .5 + variable MAXINT [expr {0x7FFFFFFF}] + + # commands is the list of subcommands recognized by the skiplist + variable commands [list \ + "destroy" \ + "delete" \ + "insert" \ + "search" \ + "size" \ + "walk" \ + ] + + # State variables that can be set in the instantiation + variable vars [list maxlevel probability] + + # Only export one command, the one used to instantiate a new skiplist + namespace export skiplist +} + +# ::struct::skiplist::skiplist -- +# +# Create a new skiplist with a given name; if no name is given, use +# skiplistX, where X is a number. +# +# Arguments: +# name name of the skiplist; if null, generate one. +# +# Results: +# name name of the skiplist created + +proc ::struct::skiplist::skiplist {{name ""} args} { + set usage "skiplist name ?-maxlevel ##? ?-probability ##?" + variable counter + + if { [llength [info level 0]] == 1 } { + incr counter + set name "skiplist${counter}" + } + + if { ![string equal [info commands ::$name] ""] } { + error "command \"$name\" already exists, unable to create skiplist" + } + + # Handle the optional arguments + set more_eval "" + for {set i 0} {$i < [llength $args]} {incr i} { + set flag [lindex $args $i] + incr i + if { $i >= [llength $args] } { + error "value for \"$flag\" missing: should be \"$usage\"" + } + set value [lindex $args $i] + switch -glob -- $flag { + "-maxl*" { + set n [catch {set value [expr $value]}] + if {$n || $value <= 0} { + error "value for the maxlevel option must be greater than 0" + } + append more_eval "; set state(maxlevel) $value" + } + "-prob*" { + set n [catch {set value [expr $value]}] + if {$n || $value <= 0 || $value >= 1} { + error "probability must be between 0 and 1" + } + append more_eval "; set state(prob) $value" + } + default { + error "unknown option \"$flag\": should be \"$usage\"" + } + } + } + + # Set up the namespace for this skiplist + namespace eval ::struct::skiplist::skiplist$name { + variable state + variable nodes + + # NB. maxlevel and prob may be overridden by $more_eval at the end + set state(maxlevel) $::struct::skiplist::MAXLEVEL + set state(prob) $::struct::skiplist::PROB + set state(level) 1 + set state(cnt) 0 + set state(size) 0 + + set nodes(nil,key) $::struct::skiplist::MAXINT + set nodes(header,key) "---" + set nodes(header,value) "---" + + for {set i 1} {$i < $state(maxlevel)} {incr i} { + set nodes(header,$i) nil + } + } $more_eval + + # Create the command to manipulate the skiplist + interp alias {} ::$name {} ::struct::skiplist::SkiplistProc $name + + return $name +} + +########################### +# Private functions follow + +# ::struct::skiplist::SkiplistProc -- +# +# Command that processes all skiplist object commands. +# +# Arguments: +# name name of the skiplist object to manipulate. +# args command name and args for the command +# +# Results: +# Varies based on command to perform + +proc ::struct::skiplist::SkiplistProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + if { [llength [info commands ::struct::skiplist::_$cmd]] == 0 } { + variable commands + set optlist [join $commands ", "] + set optlist [linsert $optlist "end-1" "or"] + error "bad option \"$cmd\": must be $optlist" + } + eval [linsert $args 0 ::struct::skiplist::_$cmd $name] +} + +## ::struct::skiplist::_destroy -- +# +# Destroy a skiplist, including its associated command and data storage. +# +# Arguments: +# name name of the skiplist. +# +# Results: +# None. + +proc ::struct::skiplist::_destroy {name} { + namespace delete ::struct::skiplist::skiplist$name + interp alias {} ::$name {} +} + +# ::struct::skiplist::_search -- +# +# Searches for a key in a skiplist +# +# Arguments: +# name name of the skiplist. +# key key for the node to search for +# +# Results: +# 0 if not found +# [list 1 node_value] if found + +proc ::struct::skiplist::_search {name key} { + upvar ::struct::skiplist::skiplist${name}::state state + upvar ::struct::skiplist::skiplist${name}::nodes nodes + + set x header + for {set i $state(level)} {$i >= 1} {incr i -1} { + while {1} { + set fwd $nodes($x,$i) + if {$nodes($fwd,key) == $::struct::skiplist::MAXINT} break + if {$nodes($fwd,key) >= $key} break + set x $fwd + } + } + set x $nodes($x,1) + if {$nodes($x,key) == $key} { + return [list 1 $nodes($x,value)] + } + return 0 +} + +# ::struct::skiplist::_insert -- +# +# Add a node to a skiplist. +# +# Arguments: +# name name of the skiplist. +# key key for the node to insert +# value value of the node to insert +# +# Results: +# 0 if new node was created +# level if existing node was updated + +proc ::struct::skiplist::_insert {name key value} { + upvar ::struct::skiplist::skiplist${name}::state state + upvar ::struct::skiplist::skiplist${name}::nodes nodes + + set x header + for {set i $state(level)} {$i >= 1} {incr i -1} { + while {1} { + set fwd $nodes($x,$i) + if {$nodes($fwd,key) == $::struct::skiplist::MAXINT} break + if {$nodes($fwd,key) >= $key} break + set x $fwd + } + set update($i) $x + } + set x $nodes($x,1) + + # Does the node already exist? + if {$nodes($x,key) == $key} { + set nodes($x,value) $value + return 0 + } + + # Here to insert item + incr state(size) + set lvl [randomLevel $state(prob) $state(level) $state(maxlevel)] + + # Did the skip list level increase??? + if {$lvl > $state(level)} { + for {set i [expr {$state(level) + 1}]} {$i <= $lvl} {incr i} { + set update($i) header + } + set state(level) $lvl + } + + # Create a unique new node name and fill in the key, value parts + set x [incr state(cnt)] + set nodes($x,key) $key + set nodes($x,value) $value + + for {set i 1} {$i <= $lvl} {incr i} { + set nodes($x,$i) $nodes($update($i),$i) + set nodes($update($i),$i) $x + } + + return $lvl +} + +# ::struct::skiplist::_delete -- +# +# Deletes a node from a skiplist +# +# Arguments: +# name name of the skiplist. +# key key for the node to delete +# +# Results: +# 1 if we deleted a node +# 0 otherwise + +proc ::struct::skiplist::_delete {name key} { + upvar ::struct::skiplist::skiplist${name}::state state + upvar ::struct::skiplist::skiplist${name}::nodes nodes + + set x header + for {set i $state(level)} {$i >= 1} {incr i -1} { + while {1} { + set fwd $nodes($x,$i) + if {$nodes($fwd,key) >= $key} break + set x $fwd + } + set update($i) $x + } + set x $nodes($x,1) + + # Did we find a node to delete? + if {$nodes($x,key) != $key} { + return 0 + } + + # Here when we found a node to delete + incr state(size) -1 + + # Unlink this node from all the linked lists that include to it + for {set i 1} {$i <= $state(level)} {incr i} { + set fwd $nodes($update($i),$i) + if {$nodes($fwd,key) != $key} break + set nodes($update($i),$i) $nodes($x,$i) + } + + # Delete all traces of this node + foreach v [array names nodes($x,*)] { + unset nodes($v) + } + + # Fix up the level in case it went down + while {$state(level) > 1} { + if {! [string equal "nil" $nodes(header,$state(level))]} break + incr state(level) -1 + } + + return 1 +} + +# ::struct::skiplist::_size -- +# +# Returns how many nodes are in the skiplist +# +# Arguments: +# name name of the skiplist. +# +# Results: +# number of nodes in the skiplist + +proc ::struct::skiplist::_size {name} { + upvar ::struct::skiplist::skiplist${name}::state state + + return $state(size) +} + +# ::struct::skiplist::_walk -- +# +# Walks a skiplist performing a specified command on each node. +# Command is executed at the global level with the actual command +# executed is: command key value +# +# Arguments: +# name name of the skiplist. +# cmd command to run on each node +# +# Results: +# none. + +proc ::struct::skiplist::_walk {name cmd} { + upvar ::struct::skiplist::skiplist${name}::nodes nodes + + for {set x $nodes(header,1)} {$x != "nil"} {set x $nodes($x,1)} { + # Evaluate the command at this node + set cmdcpy $cmd + lappend cmdcpy $nodes($x,key) $nodes($x,value) + uplevel 2 $cmdcpy + } +} + +# ::struct::skiplist::randomLevel -- +# +# Generates a random level for a new node. We limit it to 1 greater +# than the current level. +# +# Arguments: +# prob probability to use in generating level +# level current biggest level +# maxlevel biggest possible level +# +# Results: +# an integer between 1 and $maxlevel + +proc ::struct::skiplist::randomLevel {prob level maxlevel} { + + set lvl 1 + while {(rand() < $prob) && ($lvl < $maxlevel)} { + incr lvl + } + + if {$lvl > $level} { + set lvl [expr {$level + 1}] + } + + return $lvl +} + +# ::struct::skiplist::_dump -- +# +# Dumps out a skip list. Useful for debugging. +# +# Arguments: +# name name of the skiplist. +# +# Results: +# none. + +proc ::struct::skiplist::_dump {name} { + upvar ::struct::skiplist::skiplist${name}::state state + upvar ::struct::skiplist::skiplist${name}::nodes nodes + + + puts "Current level $state(level)" + puts "Maxlevel: $state(maxlevel)" + puts "Probability: $state(prob)" + puts "" + puts "NODE KEY FORWARD" + for {set x header} {$x != "nil"} {set x $nodes($x,1)} { + puts -nonewline [format "%-6s %3s %4s" $x $nodes($x,key) $nodes($x,1)] + for {set i 2} {[info exists nodes($x,$i)]} {incr i} { + puts -nonewline [format %4s $nodes($x,$i)] + } + puts "" + } +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'skiplist::skiplist' into the general structure namespace. + namespace import -force skiplist::skiplist + namespace export skiplist +} +package provide struct::skiplist 1.4 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/stack.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/stack.tcl new file mode 100644 index 00000000..da8d66f9 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/stack.tcl @@ -0,0 +1,183 @@ +# stack.tcl -- +# +# Implementation of a stack data structure for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2008 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: stack.tcl,v 1.20 2012/11/21 22:36:18 andreas_kupries Exp $ + +# @mdgen EXCLUDE: stack_c.tcl + +package require Tcl 8.5 9 +namespace eval ::struct::stack {} + +# ### ### ### ######### ######### ######### +## Management of stack implementations. + +# ::struct::stack::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::stack::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of stack requires Tcl 8.4. + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::stack_critcl]] + } + tcl { + variable selfdir + if {![catch {package require TclOO 0.6.1-} mx]} { + source [file join $selfdir stack_oo.tcl] + } else { + source [file join $selfdir stack_tcl.tcl] + } + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::stack::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::stack::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::stack ::struct::stack_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::stack_$key ::struct::stack + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +# ::struct::stack::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::stack::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::stack::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::stack::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::stack::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::stack { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::stack { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export stack +} + +package provide struct::stack 1.5.4 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/stack_c.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/stack_c.tcl new file mode 100644 index 00000000..f3fde2e4 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/stack_c.tcl @@ -0,0 +1,156 @@ +# stackc.tcl -- +# +# Implementation of a stack data structure for Tcl. +# This code based on critcl, API compatible to the PTI [x]. +# [x] Pure Tcl Implementation. +# +# Copyright (c) 2008 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: stack_c.tcl,v 1.1 2008/06/19 23:03:35 andreas_kupries Exp $ + +package require critcl +# @sak notprovided struct_stackc +package provide struct_stackc 1.3.1 +package require Tcl 8.5 9 + +namespace eval ::struct { + # Supporting code for the main command. + + catch { + #critcl::cheaders -g + #critcl::debug memory symbols + } + + critcl::cheaders stack/*.h + critcl::csources stack/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include + #include + #include + #include + + /* .................................................. */ + /* Global stack management, per interp + */ + + typedef struct SDg { + long int counter; + char buf [50]; + } SDg; + + static void + SDgrelease (ClientData cd, Tcl_Interp* interp) + { + ckfree((char*) cd); + } + + static CONST char* + SDnewName (Tcl_Interp* interp) + { +#define KEY "tcllib/struct::stack/critcl" + + Tcl_InterpDeleteProc* proc = SDgrelease; + SDg* sdg; + + sdg = Tcl_GetAssocData (interp, KEY, &proc); + if (sdg == NULL) { + sdg = (SDg*) ckalloc (sizeof (SDg)); + sdg->counter = 0; + + Tcl_SetAssocData (interp, KEY, proc, + (ClientData) sdg); + } + + sdg->counter ++; + sprintf (sdg->buf, "stack%ld", sdg->counter); + return sdg->buf; + +#undef KEY + } + + static void + SDdeleteCmd (ClientData clientData) + { + /* Release the whole stack. */ + st_delete ((S*) clientData); + } + } + + # Main command, stack creation. + + critcl::ccommand stack_critcl {dummy interp objc objv} { + /* Syntax + * - epsilon |1 + * - name |2 + */ + + CONST char* name; + S* sd; + Tcl_Obj* fqn; + Tcl_CmdInfo ci; + +#define USAGE "?name?" + + if ((objc != 2) && (objc != 1)) { + Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ + return TCL_ERROR; + } + + if (objc < 2) { + name = SDnewName (interp); + } else { + name = Tcl_GetString (objv [1]); + } + + if (!Tcl_StringMatch (name, "::*")) { + /* Relative name. Prefix with current namespace */ + + Tcl_Eval (interp, "namespace current"); + fqn = Tcl_GetObjResult (interp); + fqn = Tcl_DuplicateObj (fqn); + Tcl_IncrRefCount (fqn); + + if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { + Tcl_AppendToObj (fqn, "::", -1); /* OK tcl9 */ + } + Tcl_AppendToObj (fqn, name, -1); /* OK tcl9 */ + } else { + fqn = Tcl_NewStringObj (name, -1); /* OK tcl9 */ + Tcl_IncrRefCount (fqn); + } + Tcl_ResetResult (interp); + + if (Tcl_GetCommandInfo (interp, + Tcl_GetString (fqn), + &ci)) { + Tcl_Obj* err; + + err = Tcl_NewObj (); + Tcl_AppendToObj (err, "command \"", -1); /* OK tcl9 */ + Tcl_AppendObjToObj (err, fqn); + Tcl_AppendToObj (err, "\" already exists, unable to create stack", -1); /* OK tcl9 */ + + Tcl_DecrRefCount (fqn); + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + sd = st_new(); + sd->cmd = Tcl_CreateObjCommand2 (interp, Tcl_GetString (fqn), + stms_objcmd, (ClientData) sd, + SDdeleteCmd); + + Tcl_SetObjResult (interp, fqn); + Tcl_DecrRefCount (fqn); + return TCL_OK; + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/stack_oo.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/stack_oo.tcl new file mode 100644 index 00000000..ff049258 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/stack_oo.tcl @@ -0,0 +1,296 @@ +# stack.tcl -- +# +# Stack implementation for Tcl 8.6+, or 8.5 + TclOO +# +# Copyright (c) 2010 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: stack_oo.tcl,v 1.4 2010/09/10 17:31:04 andreas_kupries Exp $ + +package require Tcl 8.5 9 +package require TclOO 0.6.1- ; # This includes 1 and higher. + +# Cleanup first +catch {namespace delete ::struct::stack::stack_oo} +catch {rename ::struct::stack::stack_oo {}} + +oo::class create ::struct::stack::stack_oo { + + variable mystack + + constructor {} { + set mystack {} + return + } + + # clear -- + # + # Clear a stack. + # + # Results: + # None. + + method clear {} { + set mystack {} + return + } + + # get -- + # + # Retrieve the whole contents of the stack. + # + # Results: + # items list of all items in the stack. + + method get {} { + return [lreverse $mystack] + } + + method getr {} { + return $mystack + } + + # peek -- + # + # Retrieve the value of an item on the stack without popping it. + # + # Arguments: + # count number of items to pop; defaults to 1 + # + # Results: + # items top count items from the stack; if there are not enough items + # to fulfill the request, throws an error. + + method peek {{count 1}} { + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [llength $mystack] } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item peeks are not + # listified + return [lindex $mystack end] + } + + # Otherwise, return a list of items + incr count -1 + return [lreverse [lrange $mystack end-$count end]] + } + + method peekr {{count 1}} { + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [llength $mystack] } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item peeks are not + # listified + return [lindex $mystack end] + } + + # Otherwise, return a list of items, in reversed order. + incr count -1 + return [lrange $mystack end-$count end] + } + + # trim -- + # + # Pop items off a stack until a maximum size is reached. + # + # Arguments: + # count requested size of the stack. + # + # Results: + # item List of items trimmed, may be empty. + + method trim {newsize} { + if { ![string is integer -strict $newsize]} { + return -code error "expected integer but got \"$newsize\"" + } elseif { $newsize < 0 } { + return -code error "invalid size $newsize" + } elseif { $newsize >= [llength $mystack] } { + # Stack is smaller than requested, do nothing. + return {} + } + + # newsize < [llength $mystack] + # pop '[llength $mystack]' - newsize elements. + + if {!$newsize} { + set result [lreverse [my K $mystack [unset mystack]]] + set mystack {} + } else { + set result [lreverse [lrange $mystack $newsize end]] + set mystack [lreplace [my K $mystack [unset mystack]] $newsize end] + } + + return $result + } + + method trim* {newsize} { + if { ![string is integer -strict $newsize]} { + return -code error "expected integer but got \"$newsize\"" + } elseif { $newsize < 0 } { + return -code error "invalid size $newsize" + } + + if { $newsize >= [llength $mystack] } { + # Stack is smaller than requested, do nothing. + return + } + + # newsize < [llength $mystack] + # pop '[llength $mystack]' - newsize elements. + + # No results, compared to trim. + + if {!$newsize} { + set mystack {} + } else { + set mystack [lreplace [my K $mystack [unset mystack]] $newsize end] + } + + return + } + + # pop -- + # + # Pop an item off a stack. + # + # Arguments: + # count number of items to pop; defaults to 1 + # + # Results: + # item top count items from the stack; if the stack is empty, + # returns a list of count nulls. + + method pop {{count 1}} { + if { $count < 1 } { + return -code error "invalid item count $count" + } + + set ssize [llength $mystack] + + if { $count > $ssize } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item pops are not + # listified + set item [lindex $mystack end] + if {$count == $ssize} { + set mystack [list] + } else { + set mystack [lreplace [my K $mystack [unset mystack]] end end] + } + return $item + } + + # Otherwise, return a list of items, and remove the items from the + # stack. + if {$count == $ssize} { + set result [lreverse [my K $mystack [unset mystack]]] + set mystack [list] + } else { + incr count -1 + set result [lreverse [lrange $mystack end-$count end]] + set mystack [lreplace [my K $mystack [unset mystack]] end-$count end] + } + return $result + } + + # push -- + # + # Push an item onto a stack. + # + # Arguments: + # args items to push. + # + # Results: + # None. + + method push {args} { + if {![llength $args]} { + return -code error "wrong # args: should be \"[self] push item ?item ...?\"" + } + + lappend mystack {*}$args + return + } + + # rotate -- + # + # Rotate the top count number of items by step number of steps. + # + # Arguments: + # count number of items to rotate. + # steps number of steps to rotate. + # + # Results: + # None. + + method rotate {count steps} { + set len [llength $mystack] + if { $count > $len } { + return -code error "insufficient items on stack to fill request" + } + + # Rotation algorithm: + # do + # Find the insertion point in the stack + # Move the end item to the insertion point + # repeat $steps times + + set start [expr {$len - $count}] + set steps [expr {$steps % $count}] + + if {$steps == 0} return + + for {set i 0} {$i < $steps} {incr i} { + set item [lindex $mystack end] + set mystack [linsert \ + [lreplace \ + [my K $mystack [unset mystack]] \ + end end] $start $item] + } + return + } + + # size -- + # + # Return the number of objects on a stack. + # + # Results: + # count number of items on the stack. + + method size {} { + return [llength $mystack] + } + + # ### ### ### ######### ######### ######### + + method K {x y} { set x } +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'stack::stack' into the general structure namespace for + # pickup by the main management. + + proc stack_tcl {args} { + if {[llength $args]} { + uplevel 1 [::list ::struct::stack::stack_oo create {*}$args] + } else { + uplevel 1 [::list ::struct::stack::stack_oo new] + } + } +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/stack_tcl.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/stack_tcl.tcl new file mode 100644 index 00000000..1bcc6047 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/stack_tcl.tcl @@ -0,0 +1,505 @@ +# stack.tcl -- +# +# Stack implementation for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: stack_tcl.tcl,v 1.3 2010/03/15 17:17:38 andreas_kupries Exp $ + +namespace eval ::struct::stack { + # counter is used to give a unique name for unnamed stacks + variable counter 0 + + # Only export one command, the one used to instantiate a new stack + namespace export stack_tcl +} + +# ::struct::stack::stack_tcl -- +# +# Create a new stack with a given name; if no name is given, use +# stackX, where X is a number. +# +# Arguments: +# name name of the stack; if null, generate one. +# +# Results: +# name name of the stack created + +proc ::struct::stack::stack_tcl {args} { + variable I::stacks + variable counter + + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "stack${counter}" + } + 2 { + # Standard call. New empty stack. + set name [lindex $args 0] + } + default { + # Error. + return -code error \ + "wrong # args: should be \"stack ?name?\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + if {[llength [info commands $name]]} { + return -code error \ + "command \"$name\" already exists, unable to create stack" + } + + set stacks($name) [list ] + + # Create the command to manipulate the stack + interp alias {} $name {} ::struct::stack::StackProc $name + + return $name +} + +########################## +# Private functions follow + +# ::struct::stack::StackProc -- +# +# Command that processes all stack object commands. +# +# Arguments: +# name name of the stack object to manipulate. +# args command name and args for the command +# +# Results: +# Varies based on command to perform + +if {[package vsatisfies [package provide Tcl] 8.5 9]} { + # In 8.5+ we can do an ensemble for fast dispatch. + + proc ::struct::stack::StackProc {name cmd args} { + # Shuffle method to front and then simply run the ensemble. + # Dispatch, argument checking, and error message generation + # are all done in the C-level. + + I $cmd $name {*}$args + } + + namespace eval ::struct::stack::I { + namespace export clear destroy get getr peek peekr \ + trim trim* pop push rotate size + namespace ensemble create + } + +} else { + # Before 8.5 we have to code our own dispatch, including error + # checking. + + proc ::struct::stack::StackProc {name cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + if {![llength [info commands ::struct::stack::I::$cmd]]} { + set optlist [lsort [info commands ::struct::stack::I::*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + if {($p eq "K") || ($p eq "lreverse")} continue + lappend xlist $p + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + + uplevel 1 [linsert $args 0 ::struct::stack::I::$cmd $name] + } +} + +# ### ### ### ######### ######### ######### + +namespace eval ::struct::stack::I { + # The stacks array holds all of the stacks you've made + variable stacks +} + +# ### ### ### ######### ######### ######### + +# ::struct::stack::I::clear -- +# +# Clear a stack. +# +# Arguments: +# name name of the stack object. +# +# Results: +# None. + +proc ::struct::stack::I::clear {name} { + variable stacks + set stacks($name) {} + return +} + +# ::struct::stack::I::destroy -- +# +# Destroy a stack object by removing it's storage space and +# eliminating it's proc. +# +# Arguments: +# name name of the stack object. +# +# Results: +# None. + +proc ::struct::stack::I::destroy {name} { + variable stacks + unset stacks($name) + interp alias {} $name {} + return +} + +# ::struct::stack::I::get -- +# +# Retrieve the whole contents of the stack. +# +# Arguments: +# name name of the stack object. +# +# Results: +# items list of all items in the stack. + +proc ::struct::stack::I::get {name} { + variable stacks + return [lreverse $stacks($name)] +} + +proc ::struct::stack::I::getr {name} { + variable stacks + return $stacks($name) +} + +# ::struct::stack::I::peek -- +# +# Retrieve the value of an item on the stack without popping it. +# +# Arguments: +# name name of the stack object. +# count number of items to pop; defaults to 1 +# +# Results: +# items top count items from the stack; if there are not enough items +# to fulfill the request, throws an error. + +proc ::struct::stack::I::peek {name {count 1}} { + variable stacks + upvar 0 stacks($name) mystack + + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [llength $mystack] } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item peeks are not + # listified + return [lindex $mystack end] + } + + # Otherwise, return a list of items + incr count -1 + return [lreverse [lrange $mystack end-$count end]] +} + +proc ::struct::stack::I::peekr {name {count 1}} { + variable stacks + upvar 0 stacks($name) mystack + + if { $count < 1 } { + return -code error "invalid item count $count" + } elseif { $count > [llength $mystack] } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item peeks are not + # listified + return [lindex $mystack end] + } + + # Otherwise, return a list of items, in reversed order. + incr count -1 + return [lrange $mystack end-$count end] +} + +# ::struct::stack::I::trim -- +# +# Pop items off a stack until a maximum size is reached. +# +# Arguments: +# name name of the stack object. +# count requested size of the stack. +# +# Results: +# item List of items trimmed, may be empty. + +proc ::struct::stack::I::trim {name newsize} { + variable stacks + upvar 0 stacks($name) mystack + + if { ![string is integer -strict $newsize]} { + return -code error "expected integer but got \"$newsize\"" + } elseif { $newsize < 0 } { + return -code error "invalid size $newsize" + } elseif { $newsize >= [llength $mystack] } { + # Stack is smaller than requested, do nothing. + return {} + } + + # newsize < [llength $mystack] + # pop '[llength $mystack]' - newsize elements. + + if {!$newsize} { + set result [lreverse [K $mystack [unset mystack]]] + set mystack {} + } else { + set result [lreverse [lrange $mystack $newsize end]] + set mystack [lreplace [K $mystack [unset mystack]] $newsize end] + } + + return $result +} + +proc ::struct::stack::I::trim* {name newsize} { + if { ![string is integer -strict $newsize]} { + return -code error "expected integer but got \"$newsize\"" + } elseif { $newsize < 0 } { + return -code error "invalid size $newsize" + } + + variable stacks + upvar 0 stacks($name) mystack + + if { $newsize >= [llength $mystack] } { + # Stack is smaller than requested, do nothing. + return + } + + # newsize < [llength $mystack] + # pop '[llength $mystack]' - newsize elements. + + # No results, compared to trim. + + if {!$newsize} { + set mystack {} + } else { + set mystack [lreplace [K $mystack [unset mystack]] $newsize end] + } + + return +} + +# ::struct::stack::I::pop -- +# +# Pop an item off a stack. +# +# Arguments: +# name name of the stack object. +# count number of items to pop; defaults to 1 +# +# Results: +# item top count items from the stack; if the stack is empty, +# returns a list of count nulls. + +proc ::struct::stack::I::pop {name {count 1}} { + variable stacks + upvar 0 stacks($name) mystack + + if { $count < 1 } { + return -code error "invalid item count $count" + } + set ssize [llength $mystack] + if { $count > $ssize } { + return -code error "insufficient items on stack to fill request" + } + + if { $count == 1 } { + # Handle this as a special case, so single item pops are not + # listified + set item [lindex $mystack end] + if {$count == $ssize} { + set mystack [list] + } else { + set mystack [lreplace [K $mystack [unset mystack]] end end] + } + return $item + } + + # Otherwise, return a list of items, and remove the items from the + # stack. + if {$count == $ssize} { + set result [lreverse [K $mystack [unset mystack]]] + set mystack [list] + } else { + incr count -1 + set result [lreverse [lrange $mystack end-$count end]] + set mystack [lreplace [K $mystack [unset mystack]] end-$count end] + } + return $result + + # ------------------------------------------------------- + + set newsize [expr {[llength $mystack] - $count}] + + if {!$newsize} { + set result [lreverse [K $mystack [unset mystack]]] + set mystack {} + } else { + set result [lreverse [lrange $mystack $newsize end]] + set mystack [lreplace [K $mystack [unset mystack]] $newsize end] + } + + if {$count == 1} { + set result [lindex $result 0] + } + + return $result +} + +# ::struct::stack::I::push -- +# +# Push an item onto a stack. +# +# Arguments: +# name name of the stack object +# args items to push. +# +# Results: +# None. + +if {[package vsatisfies [package provide Tcl] 8.5 9]} { + + proc ::struct::stack::I::push {name args} { + if {![llength $args]} { + return -code error "wrong # args: should be \"$name push item ?item ...?\"" + } + + variable stacks + upvar 0 stacks($name) mystack + + lappend mystack {*}$args + return + } +} else { + proc ::struct::stack::I::push {name args} { + if {![llength $args]} { + return -code error "wrong # args: should be \"$name push item ?item ...?\"" + } + + variable stacks + upvar 0 stacks($name) mystack + + if {[llength $args] == 1} { + lappend mystack [lindex $args 0] + } else { + eval [linsert $args 0 lappend mystack] + } + return + } +} + +# ::struct::stack::I::rotate -- +# +# Rotate the top count number of items by step number of steps. +# +# Arguments: +# name name of the stack object. +# count number of items to rotate. +# steps number of steps to rotate. +# +# Results: +# None. + +proc ::struct::stack::I::rotate {name count steps} { + variable stacks + upvar 0 stacks($name) mystack + set len [llength $mystack] + if { $count > $len } { + return -code error "insufficient items on stack to fill request" + } + + # Rotation algorithm: + # do + # Find the insertion point in the stack + # Move the end item to the insertion point + # repeat $steps times + + set start [expr {$len - $count}] + set steps [expr {$steps % $count}] + + if {$steps == 0} return + + for {set i 0} {$i < $steps} {incr i} { + set item [lindex $mystack end] + set mystack [linsert \ + [lreplace \ + [K $mystack [unset mystack]] \ + end end] $start $item] + } + return +} + +# ::struct::stack::I::size -- +# +# Return the number of objects on a stack. +# +# Arguments: +# name name of the stack object. +# +# Results: +# count number of items on the stack. + +proc ::struct::stack::I::size {name} { + variable stacks + return [llength $stacks($name)] +} + +# ### ### ### ######### ######### ######### + +proc ::struct::stack::I::K {x y} { set x } + +if {![llength [info commands lreverse]]} { + proc ::struct::stack::I::lreverse {x} { + # assert (llength(x) > 1) + set l [llength $x] + if {$l <= 1} { return $x } + set r [list] + while {$l} { lappend r [lindex $x [incr l -1]] } + return $r + } +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'stack::stack' into the general structure namespace for + # pickup by the main management. + namespace import -force stack::stack_tcl +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/struct.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/struct.tcl new file mode 100644 index 00000000..117b6696 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/struct.tcl @@ -0,0 +1,18 @@ +package require Tcl 8.5 9 +package require struct::graph 2.0 +package require struct::queue 1.2.1 +package require struct::stack 1.2.1 +package require struct::tree 2.0 +package require struct::matrix 2.0 +package require struct::pool 1.2.1 +package require struct::record 1.2.1 +package require struct::list 1.4 +package require struct::set 2.1 +package require struct::prioqueue 1.3 +package require struct::skiplist 1.4 + +namespace eval ::struct { + namespace export * +} + +package provide struct 2.2 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/struct1.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/struct1.tcl new file mode 100644 index 00000000..af3f6d9d --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/struct1.tcl @@ -0,0 +1,17 @@ +package require Tcl 8.5 9 +package require struct::graph 1.2.2 +package require struct::queue 1.2.1 +package require struct::stack 1.2.1 +package require struct::tree 1.2.1 +package require struct::matrix 1.2.1 +package require struct::pool 1.2.1 +package require struct::record 1.2.1 +package require struct::list 1.4 +package require struct::prioqueue 1.3 +package require struct::skiplist 1.4 + +namespace eval ::struct { + namespace export * +} + +package provide struct 1.5 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/tree.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/tree.tcl new file mode 100644 index 00000000..52b9fe71 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/tree.tcl @@ -0,0 +1,182 @@ +# tree.tcl -- +# +# Implementation of a tree data structure for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: tree.tcl,v 1.45 2009/06/22 18:21:59 andreas_kupries Exp $ + +# @mdgen EXCLUDE: tree_c.tcl + +package require Tcl 8.5 9 +package require struct::list + +namespace eval ::struct::tree {} + +# ### ### ### ######### ######### ######### +## Management of tree implementations. + +# ::struct::tree::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::tree::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of tree requires Tcl 8.4. + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::tree_critcl]] + } + tcl { + variable selfdir + source [file join $selfdir tree_tcl.tcl] + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::tree::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::tree::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::tree ::struct::tree_$loaded + rename ::struct::tree::prune ::struct::tree::prune_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::tree_$key ::struct::tree + rename ::struct::tree::prune_$key ::struct::tree::prune + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +# ::struct::tree::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::tree::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::tree::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::tree::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::tree::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::tree { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::tree { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export tree +} + +package provide struct::tree 2.1.3 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/tree1.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/tree1.tcl new file mode 100644 index 00000000..9de0e0b9 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/tree1.tcl @@ -0,0 +1,1485 @@ +# tree.tcl -- +# +# Implementation of a tree data structure for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: tree1.tcl,v 1.5 2005/10/04 17:15:05 andreas_kupries Exp $ + +package require Tcl 8.5 9 + +namespace eval ::struct {} + +namespace eval ::struct::tree { + # Data storage in the tree module + # ------------------------------- + # + # There's a lot of bits to keep track of for each tree: + # nodes + # node values + # node relationships + # + # It would quickly become unwieldy to try to keep these in arrays or lists + # within the tree namespace itself. Instead, each tree structure will get + # its own namespace. Each namespace contains: + # children array mapping nodes to their children list + # parent array mapping nodes to their parent node + # node:$node array mapping keys to values for the node $node + + # counter is used to give a unique name for unnamed trees + variable counter 0 + + # Only export one command, the one used to instantiate a new tree + namespace export tree +} + +# ::struct::tree::tree -- +# +# Create a new tree with a given name; if no name is given, use +# treeX, where X is a number. +# +# Arguments: +# name Optional name of the tree; if null or not given, generate one. +# +# Results: +# name Name of the tree created + +proc ::struct::tree::tree {{name ""}} { + variable counter + + if {[llength [info level 0]] == 1} { + incr counter + set name "tree${counter}" + } + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 namespace current] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + if {[llength [info commands $name]]} { + return -code error \ + "command \"$name\" already exists, unable to create tree" + } + + # Set up the namespace for the object, + # identical to the object command. + namespace eval $name { + # Set up root node's child list + variable children + set children(root) [list] + + # Set root node's parent + variable parent + set parent(root) [list] + + # Set up the node attribute mapping + variable attribute + array set attribute {} + + # Set up a counter for use in creating unique node names + variable nextUnusedNode + set nextUnusedNode 1 + + # Set up a counter for use in creating node attribute arrays. + variable nextAttr + set nextAttr 0 + } + + # Create the command to manipulate the tree + interp alias {} ::$name {} ::struct::tree::TreeProc $name + + return $name +} + +########################## +# Private functions follow + +# ::struct::tree::TreeProc -- +# +# Command that processes all tree object commands. +# +# Arguments: +# name Name of the tree object to manipulate. +# cmd Subcommand to invoke. +# args Arguments for subcommand. +# +# Results: +# Varies based on command to perform + +proc ::struct::tree::TreeProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub _$cmd + if { [llength [info commands ::struct::tree::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::tree::_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 1 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + return [uplevel 1 [linsert $args 0 ::struct::tree::$sub $name]] +} + +# ::struct::tree::_children -- +# +# Return the child list for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# children List of children for the node. + +proc ::struct::tree::_children {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + return $children($node) +} + +# ::struct::tree::_cut -- +# +# Destroys the specified node of a tree, but not its children. +# These children are made into children of the parent of the +# destroyed node at the index of the destroyed node. +# +# Arguments: +# name Name of the tree object. +# node Node to look up and cut. +# +# Results: +# None. + +proc ::struct::tree::_cut {name node} { + if { [string equal $node "root"] } { + # Can't delete the special root node + return -code error "cannot cut root node" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + + # Locate our parent, children and our location in the parent + set parentNode $parent($node) + set childNodes $children($node) + + set index [lsearch -exact $children($parentNode) $node] + + # Excise this node from the parent list, + set newChildren [lreplace $children($parentNode) $index $index] + + # Put each of the children of $node into the parent's children list, + # in the place of $node, and update the parent pointer of those nodes. + foreach child $childNodes { + set newChildren [linsert $newChildren $index $child] + set parent($child) $parentNode + incr index + } + set children($parentNode) $newChildren + + KillNode $name $node + return +} + +# ::struct::tree::_delete -- +# +# Remove a node from a tree, including all of its values. Recursively +# removes the node's children. +# +# Arguments: +# name Name of the tree. +# node Node to delete. +# +# Results: +# None. + +proc ::struct::tree::_delete {name node} { + if { [string equal $node "root"] } { + # Can't delete the special root node + return -code error "cannot delete root node" + } + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + # Remove this node from its parent's children list + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + set children($parentNode) [lreplace $children($parentNode) $index $index] + + # Yes, we could use the stack structure implemented in ::struct::stack, + # but it's slower than inlining it. Since we don't need a sophisticated + # stack, don't bother. + set st [list] + foreach child $children($node) { + lappend st $child + } + + KillNode $name $node + + while { [llength $st] > 0 } { + set node [lindex $st end] + set st [lreplace $st end end] + foreach child $children($node) { + lappend st $child + } + + KillNode $name $node + } + return +} + +# ::struct::tree::_depth -- +# +# Return the depth (distance from the root node) of a given node. +# +# Arguments: +# name Name of the tree. +# node Node to find. +# +# Results: +# depth Number of steps from node to the root node. + +proc ::struct::tree::_depth {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + variable ${name}::parent + set depth 0 + while { ![string equal $node "root"] } { + incr depth + set node $parent($node) + } + return $depth +} + +# ::struct::tree::_destroy -- +# +# Destroy a tree, including its associated command and data storage. +# +# Arguments: +# name Name of the tree to destroy. +# +# Results: +# None. + +proc ::struct::tree::_destroy {name} { + namespace delete $name + interp alias {} ::$name {} +} + +# ::struct::tree::_exists -- +# +# Test for existance of a given node in a tree. +# +# Arguments: +# name Name of the tree to query. +# node Node to look for. +# +# Results: +# 1 if the node exists, 0 else. + +proc ::struct::tree::_exists {name node} { + return [info exists ${name}::parent($node)] +} + +# ::struct::tree::_get -- +# +# Get a keyed value from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# flag Optional flag specifier; if present, must be "-key". +# key Optional key to lookup; defaults to data. +# +# Results: +# value Value associated with the key given. + +proc ::struct::tree::_get {name node {flag -key} {key data}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # except for the default key 'data'. + + if {[string equal $key data]} { + return "" + } + return -code error "invalid key \"$key\" for node \"$node\"" + } + + upvar ${name}::$attribute($node) data + if {![info exists data($key)]} { + return -code error "invalid key \"$key\" for node \"$node\"" + } + return $data($key) +} + +# ::struct::tree::_getall -- +# +# Get a serialized list of key/value pairs from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# +# Results: +# value A serialized list of key/value pairs. + +proc ::struct::tree::_getall {name node args} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {[llength $args]} { + return -code error "wrong # args: should be \"$name getall $node\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # Only default key is present, invisibly. + return {data {}} + } + + upvar ${name}::$attribute($node) data + return [array get data] +} + +# ::struct::tree::_keys -- +# +# Get a list of keys from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# +# Results: +# value A serialized list of key/value pairs. + +proc ::struct::tree::_keys {name node args} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {[llength $args]} { + return -code error "wrong # args: should be \"$name keys $node\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # except for the default key 'data'. + return {data} + } + + upvar ${name}::$attribute($node) data + return [array names data] +} + +# ::struct::tree::_keyexists -- +# +# Test for existance of a given key for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# flag Optional flag specifier; if present, must be "-key". +# key Optional key to lookup; defaults to data. +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::tree::_keyexists {name node {flag -key} {key data}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {![string equal $flag "-key"]} { + return -code error "invalid option \"$flag\": should be -key" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # except for the default key 'data'. + + return [string equal $key data] + } + + upvar ${name}::$attribute($node) data + return [info exists data($key)] +} + +# ::struct::tree::_index -- +# +# Determine the index of node with in its parent's list of children. +# +# Arguments: +# name Name of the tree. +# node Node to look up. +# +# Results: +# index The index of the node in its parent + +proc ::struct::tree::_index {name node} { + if { [string equal $node "root"] } { + # The special root node has no parent, thus no index in it either. + return -code error "cannot determine index of root node" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + # Locate the parent and ourself in its list of children + set parentNode $parent($node) + + return [lsearch -exact $children($parentNode) $node] +} + +# ::struct::tree::_insert -- +# +# Add a node to a tree; if the node(s) specified already exist, they +# will be moved to the given location. +# +# Arguments: +# name Name of the tree. +# parentNode Parent to add the node to. +# index Index at which to insert. +# args Node(s) to insert. If none is given, the routine +# will insert a single node with a unique name. +# +# Results: +# nodes List of nodes inserted. + +proc ::struct::tree::_insert {name parentNode index args} { + if { [llength $args] == 0 } { + # No node name was given; generate a unique one + set args [list [GenerateUniqueNodeName $name]] + } + if { ![_exists $name $parentNode] } { + return -code error "parent node \"$parentNode\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + + # Make sure the index is numeric + if { ![string is integer $index] } { + # If the index is not numeric, make it numeric by lsearch'ing for + # the value at index, then incrementing index (because "end" means + # just past the end for inserts) + set val [lindex $children($parentNode) $index] + set index [expr {[lsearch -exact $children($parentNode) $val] + 1}] + } + + foreach node $args { + if {[_exists $name $node] } { + # Move the node to its new home + if { [string equal $node "root"] } { + return -code error "cannot move root node" + } + + # Cannot make a node its own descendant (I'm my own grandpaw...) + set ancestor $parentNode + while { ![string equal $ancestor "root"] } { + if { [string equal $ancestor $node] } { + return -code error "node \"$node\" cannot be its own descendant" + } + set ancestor $parent($ancestor) + } + # Remove this node from its parent's children list + set oldParent $parent($node) + set ind [lsearch -exact $children($oldParent) $node] + set children($oldParent) [lreplace $children($oldParent) $ind $ind] + + # If the node is moving within its parent, and its old location + # was before the new location, decrement the new location, so that + # it gets put in the right spot + if { [string equal $oldParent $parentNode] && $ind < $index } { + incr index -1 + } + } else { + # Set up the new node + set children($node) [list] + } + + # Add this node to its parent's children list + set children($parentNode) [linsert $children($parentNode) $index $node] + + # Update the parent pointer for this node + set parent($node) $parentNode + incr index + } + + return $args +} + +# ::struct::tree::_isleaf -- +# +# Return whether the given node of a tree is a leaf or not. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# isleaf True if the node is a leaf; false otherwise. + +proc ::struct::tree::_isleaf {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + return [expr {[llength $children($node)] == 0}] +} + +# ::struct::tree::_move -- +# +# Move a node (and all its subnodes) from where ever it is to a new +# location in the tree. +# +# Arguments: +# name Name of the tree +# parentNode Parent to add the node to. +# index Index at which to insert. +# node Node to move; the node must exist in the tree. +# args Additional nodes to move; these nodes must exist +# in the tree. +# +# Results: +# None. + +proc ::struct::tree::_move {name parentNode index node args} { + set args [linsert $args 0 $node] + + # Can only move a node to a real location in the tree + if { ![_exists $name $parentNode] } { + return -code error "parent node \"$parentNode\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + + # Make sure the index is numeric + if { ![string is integer $index] } { + # If the index is not numeric, make it numeric by lsearch'ing for + # the value at index, then incrementing index (because "end" means + # just past the end for inserts) + set val [lindex $children($parentNode) $index] + set index [expr {[lsearch -exact $children($parentNode) $val] + 1}] + } + + # Validate all nodes to move before trying to move any. + foreach node $args { + if { [string equal $node "root"] } { + return -code error "cannot move root node" + } + + # Can only move real nodes + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Cannot move a node to be a descendant of itself + set ancestor $parentNode + while { ![string equal $ancestor "root"] } { + if { [string equal $ancestor $node] } { + return -code error "node \"$node\" cannot be its own descendant" + } + set ancestor $parent($ancestor) + } + } + + # Remove all nodes from their current parent's children list + foreach node $args { + set oldParent $parent($node) + set ind [lsearch -exact $children($oldParent) $node] + + set children($oldParent) [lreplace $children($oldParent) $ind $ind] + + # Update the nodes parent value + set parent($node) $parentNode + } + + # Add all nodes to their new parent's children list + set children($parentNode) \ + [eval [list linsert $children($parentNode) $index] $args] + + return +} + +# ::struct::tree::_next -- +# +# Return the right sibling for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to retrieve right sibling for. +# +# Results: +# sibling The right sibling for the node, or null if node was +# the rightmost child of its parent. + +proc ::struct::tree::_next {name node} { + # The 'root' has no siblings. + if { [string equal $node "root"] } { + return {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Locate the parent and our place in its list of children. + variable ${name}::parent + variable ${name}::children + + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + + # Go to the node to the right and return its name. + return [lindex $children($parentNode) [incr index]] +} + +# ::struct::tree::_numchildren -- +# +# Return the number of immediate children for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# numchildren Number of immediate children for the node. + +proc ::struct::tree::_numchildren {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + return [llength $children($node)] +} + +# ::struct::tree::_parent -- +# +# Return the name of the parent node of a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to look up. +# +# Results: +# parent Parent of node $node + +proc ::struct::tree::_parent {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + # FRINK: nocheck + return [set ${name}::parent($node)] +} + +# ::struct::tree::_previous -- +# +# Return the left sibling for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# sibling The left sibling for the node, or null if node was +# the leftmost child of its parent. + +proc ::struct::tree::_previous {name node} { + # The 'root' has no siblings. + if { [string equal $node "root"] } { + return {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Locate the parent and our place in its list of children. + variable ${name}::parent + variable ${name}::children + + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + + # Go to the node to the right and return its name. + return [lindex $children($parentNode) [incr index -1]] +} + +# ::struct::tree::_serialize -- +# +# Serialize a tree object (partially) into a transportable value. +# +# Arguments: +# name Name of the tree. +# node Root node of the serialized tree. +# +# Results: +# A list structure describing the part of the tree which was serialized. + +proc ::struct::tree::_serialize {name {node root}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + Serialize $name $node tree attr + return [list $tree [array get attr]] +} + +# ::struct::tree::_set -- +# +# Set or get a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify or query. +# args Optional arguments specifying a key and a value. Format is +# ?-key key? ?value? +# If no key is specified, the key "data" is used. +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_set {name node args} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {[llength $args] > 3} { + return -code error "wrong # args: should be \"$name set [list $node] ?-key key?\ + ?value?\"" + } + + # Process the arguments ... + + set key "data" + set haveValue 0 + if {[llength $args] > 1} { + foreach {flag key} $args break + if {![string match "${flag}*" "-key"]} { + return -code error "invalid option \"$flag\": should be key" + } + if {[llength $args] == 3} { + set haveValue 1 + set value [lindex $args end] + } + } elseif {[llength $args] == 1} { + set haveValue 1 + set value [lindex $args end] + } + + if {$haveValue} { + # Setting a value. This may have to create + # the attribute array for this particular + # node + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name $node + } + upvar ${name}::$attribute($node) data + + return [set data($key) $value] + } else { + # Getting a value + + return [_get $name $node -key $key] + } +} + +# ::struct::tree::_append -- +# +# Append a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify or query. +# args Optional arguments specifying a key and a value. Format is +# ?-key key? ?value? +# If no key is specified, the key "data" is used. +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_append {name node args} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if { + ([llength $args] != 1) && + ([llength $args] != 3) + } { + return -code error "wrong # args: should be \"$name set [list $node] ?-key key?\ + value\"" + } + if {[llength $args] == 3} { + foreach {flag key} $args break + if {![string equal $flag "-key"]} { + return -code error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name $node + } + upvar ${name}::$attribute($node) data + + return [append data($key) $value] +} + +# ::struct::tree::_lappend -- +# +# lappend a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify or query. +# args Optional arguments specifying a key and a value. Format is +# ?-key key? ?value? +# If no key is specified, the key "data" is used. +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_lappend {name node args} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if { + ([llength $args] != 1) && + ([llength $args] != 3) + } { + return -code error "wrong # args: should be \"$name lappend [list $node] ?-key key?\ + value\"" + } + if {[llength $args] == 3} { + foreach {flag key} $args break + if {![string equal $flag "-key"]} { + return -code error "invalid option \"$flag\": should be -key" + } + } else { + set key "data" + } + + set value [lindex $args end] + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name $node + } + upvar ${name}::$attribute($node) data + + return [lappend data($key) $value] +} + +# ::struct::tree::_size -- +# +# Return the number of descendants of a given node. The default node +# is the special root node. +# +# Arguments: +# name Name of the tree. +# node Optional node to start counting from (default is root). +# +# Results: +# size Number of descendants of the node. + +proc ::struct::tree::_size {name {node root}} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # If the node is the root, we can do the cheap thing and just count the + # number of nodes (excluding the root node) that we have in the tree with + # array names + if { [string equal $node "root"] } { + set size [llength [array names ${name}::parent]] + return [expr {$size - 1}] + } + + # Otherwise we have to do it the hard way and do a full tree search + variable ${name}::children + set size 0 + set st [list ] + foreach child $children($node) { + lappend st $child + } + while { [llength $st] > 0 } { + set node [lindex $st end] + set st [lreplace $st end end] + incr size + foreach child $children($node) { + lappend st $child + } + } + return $size +} + +# ::struct::tree::_splice -- +# +# Add a node to a tree, making a range of children from the given +# parent children of the new node. +# +# Arguments: +# name Name of the tree. +# parentNode Parent to add the node to. +# from Index at which to insert. +# to Optional end of the range of children to replace. +# Defaults to 'end'. +# node Optional node name; if given, must be unique. If not +# given, a unique name will be generated. +# +# Results: +# node Name of the node added to the tree. + +proc ::struct::tree::_splice {name parentNode from {to end} args} { + if { [llength $args] == 0 } { + # No node name given; generate a unique node name + set node [GenerateUniqueNodeName $name] + } else { + set node [lindex $args 0] + } + + if { [_exists $name $node] } { + return -code error "node \"$node\" already exists in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + # Save the list of children that are moving + set moveChildren [lrange $children($parentNode) $from $to] + + # Remove those children from the parent + set children($parentNode) [lreplace $children($parentNode) $from $to] + + # Add the new node + _insert $name $parentNode $from $node + + # Move the children + set children($node) $moveChildren + foreach child $moveChildren { + set parent($child) $node + } + + return $node +} + +# ::struct::tree::_swap -- +# +# Swap two nodes in a tree. +# +# Arguments: +# name Name of the tree. +# node1 First node to swap. +# node2 Second node to swap. +# +# Results: +# None. + +proc ::struct::tree::_swap {name node1 node2} { + # Can't swap the magic root node + if {[string equal $node1 "root"] || [string equal $node2 "root"]} { + return -code error "cannot swap root node" + } + + # Can only swap two real nodes + if {![_exists $name $node1]} { + return -code error "node \"$node1\" does not exist in tree \"$name\"" + } + if {![_exists $name $node2]} { + return -code error "node \"$node2\" does not exist in tree \"$name\"" + } + + # Can't swap a node with itself + if {[string equal $node1 $node2]} { + return -code error "cannot swap node \"$node1\" with itself" + } + + # Swapping nodes means swapping their labels and values + variable ${name}::children + variable ${name}::parent + + set parent1 $parent($node1) + set parent2 $parent($node2) + + # Replace node1 with node2 in node1's parent's children list, and + # node2 with node1 in node2's parent's children list + set i1 [lsearch -exact $children($parent1) $node1] + set i2 [lsearch -exact $children($parent2) $node2] + + set children($parent1) [lreplace $children($parent1) $i1 $i1 $node2] + set children($parent2) [lreplace $children($parent2) $i2 $i2 $node1] + + # Make node1 the parent of node2's children, and vis versa + foreach child $children($node2) { + set parent($child) $node1 + } + foreach child $children($node1) { + set parent($child) $node2 + } + + # Swap the children lists + set children1 $children($node1) + set children($node1) $children($node2) + set children($node2) $children1 + + if { [string equal $node1 $parent2] } { + set parent($node1) $node2 + set parent($node2) $parent1 + } elseif { [string equal $node2 $parent1] } { + set parent($node1) $parent2 + set parent($node2) $node1 + } else { + set parent($node1) $parent2 + set parent($node2) $parent1 + } + + # Swap the values + # More complicated now with the possibility that nodes do not have + # attribute storage associated with them. + + variable ${name}::attribute + + if { + [set ia [info exists attribute($node1)]] || + [set ib [info exists attribute($node2)]] + } { + # At least one of the nodes has attribute data. We simply swap + # the references to the arrays containing them. No need to + # copy the actual data around. + + if {$ia && $ib} { + set tmp $attribute($node1) + set attribute($node1) $attribute($node2) + set attribute($node2) $tmp + } elseif {$ia} { + set attribute($node2) $attribute($node1) + unset attribute($node1) + } elseif {$ib} { + set attribute($node1) $attribute($node2) + unset attribute($node2) + } else { + return -code error "Impossible condition." + } + } ; # else: No attribute storage => Nothing to do {} + + return +} + +# ::struct::tree::_unset -- +# +# Remove a keyed value from a node. +# +# Arguments: +# name Name of the tree. +# node Node to modify. +# args Optional additional args specifying which key to unset; +# if given, must be of the form "-key key". If not given, +# the key "data" is unset. +# +# Results: +# None. + +proc ::struct::tree::_unset {name node {flag -key} {key data}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {![string match "${flag}*" "-key"]} { + return -code error "invalid option \"$flag\": should be \"$name unset\ + [list $node] ?-key key?\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # except for the default key 'data'. + GenAttributeStorage $name $node + } + upvar ${name}::$attribute($node) data + + catch {unset data($key)} + return +} + +# ::struct::tree::_walk -- +# +# Walk a tree using a pre-order depth or breadth first +# search. Pre-order DFS is the default. At each node that is visited, +# a command will be called with the name of the tree and the node. +# +# Arguments: +# name Name of the tree. +# node Node at which to start. +# args Optional additional arguments specifying the type and order of +# the tree walk, and the command to execute at each node. +# Format is +# ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd +# +# Results: +# None. + +proc ::struct::tree::_walk {name node args} { + set usage "$name walk $node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd" + + if {[llength $args] > 6 || [llength $args] < 2} { + return -code error "wrong # args: should be \"$usage\"" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Set defaults + set type dfs + set order pre + set cmd "" + + for {set i 0} {$i < [llength $args]} {incr i} { + set flag [lindex $args $i] + incr i + if { $i >= [llength $args] } { + return -code error "value for \"$flag\" missing: should be \"$usage\"" + } + switch -glob -- $flag { + "-type" { + set type [string tolower [lindex $args $i]] + } + "-order" { + set order [string tolower [lindex $args $i]] + } + "-command" { + set cmd [lindex $args $i] + } + default { + return -code error "unknown option \"$flag\": should be \"$usage\"" + } + } + } + + # Make sure we have a command to run, otherwise what's the point? + if { [string equal $cmd ""] } { + return -code error "no command specified: should be \"$usage\"" + } + + # Validate that the given type is good + switch -exact -- $type { + "dfs" - "bfs" { + set type $type + } + default { + return -code error "invalid search type \"$type\": should be dfs, or bfs" + } + } + + # Validate that the given order is good + switch -exact -- $order { + "pre" - "post" - "in" - "both" { + set order $order + } + default { + return -code error "invalid search order \"$order\":\ + should be pre, post, both, or in" + } + } + + if {[string equal $order "in"] && [string equal $type "bfs"]} { + return -code error "unable to do a ${order}-order breadth first walk" + } + + # Do the walk + variable ${name}::children + set st [list ] + lappend st $node + + # Compute some flags for the possible places of command evaluation + set leave [expr {[string equal $order post] || [string equal $order both]}] + set enter [expr {[string equal $order pre] || [string equal $order both]}] + set touch [string equal $order in] + + if {$leave} { + set lvlabel leave + } elseif {$touch} { + # in-order does not provide a sense + # of nesting for the parent, hence + # no enter/leave, just 'visit'. + set lvlabel visit + } + + if { [string equal $type "dfs"] } { + # Depth-first walk, several orders of visiting nodes + # (pre, post, both, in) + + array set visited {} + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are looking at this 'node'. + # Pop it, then evaluate the command (post, both, in). + + set st [lreplace $st end end] + + if {$leave || $touch} { + # Evaluate the command at this node + WalkCall $name $node $lvlabel $cmd + } + } else { + # First visit of this 'node'. + # Do *not* pop it from the stack so that we are able + # to visit again after its children + + # Remember it. + set visited($node) . + + if {$enter} { + # Evaluate the command at this node (pre, both) + WalkCall $name $node "enter" $cmd + } + + # Add the children of this node to the stack. + # The exact behaviour depends on the chosen + # order. For pre, post, both-order we just + # have to add them in reverse-order so that + # they will be popped left-to-right. For in-order + # we have rearrange the stack so that the parent + # is revisited immediately after the first child. + # (but only if there is ore than one child,) + + set clist $children($node) + set len [llength $clist] + + if {$touch && ($len > 1)} { + # Pop node from stack, insert into list of children + set st [lreplace $st end end] + set clist [linsert $clist 1 $node] + incr len + } + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + lappend st [lindex $clist $i] + } + } + } + } else { + # Breadth first walk (pre, post, both) + # No in-order possible. Already captured. + + if {$leave} { + set backward $st + } + + while { [llength $st] > 0 } { + set node [lindex $st 0] + set st [lreplace $st 0 0] + + if {$enter} { + # Evaluate the command at this node + WalkCall $name $node "enter" $cmd + } + + # Add this node's children + # And create a mirrored version in case of post/both order. + + foreach child $children($node) { + lappend st $child + if {$leave} { + set backward [linsert $backward 0 $child] + } + } + } + + if {$leave} { + foreach node $backward { + # Evaluate the command at this node + WalkCall $name $node "leave" $cmd + } + } + } + return +} + +# ::struct::tree::WalkCall -- +# +# Helper command to 'walk' handling the evaluation +# of the user-specified command. Information about +# the tree, node and current action are substituted +# into the command before it evaluation. +# +# Arguments: +# tree Tree we are walking +# node Node we are at. +# action The current action. +# cmd The command to call, already partially substituted. +# +# Results: +# None. + +proc ::struct::tree::WalkCall {tree node action cmd} { + set subs [list %n [list $node] %a [list $action] %t [list $tree] %% %] + uplevel 2 [string map $subs $cmd] + return +} + +# ::struct::tree::GenerateUniqueNodeName -- +# +# Generate a unique node name for the given tree. +# +# Arguments: +# name Name of the tree to generate a unique node name for. +# +# Results: +# node Name of a node guaranteed to not exist in the tree. + +proc ::struct::tree::GenerateUniqueNodeName {name} { + variable ${name}::nextUnusedNode + while {[_exists $name "node${nextUnusedNode}"]} { + incr nextUnusedNode + } + return "node${nextUnusedNode}" +} + +# ::struct::tree::KillNode -- +# +# Delete all data of a node. +# +# Arguments: +# name Name of the tree containing the node +# node Name of the node to delete. +# +# Results: +# none + +proc ::struct::tree::KillNode {name node} { + variable ${name}::parent + variable ${name}::children + variable ${name}::attribute + + # Remove all record of $node + unset parent($node) + unset children($node) + + if {[info exists attribute($node)]} { + # FRINK: nocheck + unset ${name}::$attribute($node) + unset attribute($node) + } + return +} + +# ::struct::tree::GenAttributeStorage -- +# +# Create an array to store the attrributes of a node in. +# +# Arguments: +# name Name of the tree containing the node +# node Name of the node which got attributes. +# +# Results: +# none + +proc ::struct::tree::GenAttributeStorage {name node} { + variable ${name}::nextAttr + variable ${name}::attribute + + set attr "a[incr nextAttr]" + set attribute($node) $attr + upvar ${name}::$attr data + set data(data) "" + return +} + +# ::struct::tree::Serialize -- +# +# Serialize a tree object (partially) into a transportable value. +# +# Arguments: +# name Name of the tree. +# node Root node of the serialized tree. +# +# Results: +# None + +proc ::struct::tree::Serialize {name node tvar avar} { + upvar 1 $tvar tree $avar attr + + variable ${name}::children + variable ${name}::attribute + + # Store attribute data + if {[info exists attribute($node)]} { + set attr($node) [array get ${name}::$attribute($node)] + } else { + set attr($node) {} + } + + # Build tree structure as nested list. + + set subtrees [list] + foreach c $children($node) { + Serialize $name $c sub attr + lappend subtrees $sub + } + + set tree [list $node $subtrees] + return +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'tree::tree' into the general structure namespace. + namespace import -force tree::tree + namespace export tree +} +package provide struct::tree 1.2.3 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/tree_c.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/tree_c.tcl new file mode 100644 index 00000000..bb511900 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/tree_c.tcl @@ -0,0 +1,206 @@ +# treec.tcl -- +# +# Implementation of a tree data structure for Tcl. +# This code based on critcl, API compatible to the PTI [x]. +# [x] Pure Tcl Implementation. +# +# Copyright (c) 2005 Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require critcl +# @sak notprovided struct_treec +package provide struct_treec 2.1.1 +package require Tcl 8.5 9 + +namespace eval ::struct { + # Supporting code for the main command. + + catch { + #critcl::cheaders -g + #critcl::debug memory symbols + } + + critcl::cheaders tree/*.h + critcl::csources tree/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include + #include + #include + #include + #include + + /* .................................................. */ + /* Global tree management, per interp + */ + + typedef struct TDg { + long int counter; + char buf [50]; + } TDg; + + static void + TDgrelease (ClientData cd, Tcl_Interp* interp) + { + ckfree((char*) cd); + } + + static CONST char* + TDnewName (Tcl_Interp* interp) + { +#define KEY "tcllib/struct::tree/critcl" + + Tcl_InterpDeleteProc* proc = TDgrelease; + TDg* tdg; + + tdg = Tcl_GetAssocData (interp, KEY, &proc); + if (tdg == NULL) { + tdg = (TDg*) ckalloc (sizeof (TDg)); + tdg->counter = 0; + + Tcl_SetAssocData (interp, KEY, proc, + (ClientData) tdg); + } + + tdg->counter ++; + sprintf (tdg->buf, "tree%ld", tdg->counter); + return tdg->buf; + +#undef KEY + } + + static void + TDdeleteCmd (ClientData clientData) + { + /* Release the whole tree. */ + t_delete ((T*) clientData); + } + } + + # Main command, tree creation. + + critcl::ccommand tree_critcl {dummy interp objc objv} { + /* Syntax + * - epsilon |1 + * - name |2 + * - name =|:=|as|deserialize source |4 + */ + + CONST char* name; + T* td; + Tcl_Obj* fqn; + Tcl_CmdInfo ci; + +#define USAGE "?name ?=|:=|as|deserialize source??" + + if ((objc != 4) && (objc != 2) && (objc != 1)) { + Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ + return TCL_ERROR; + } + + if (objc < 2) { + name = TDnewName (interp); + } else { + name = Tcl_GetString (objv [1]); + } + + if (!Tcl_StringMatch (name, "::*")) { + /* Relative name. Prefix with current namespace */ + + Tcl_Eval (interp, "namespace current"); + fqn = Tcl_GetObjResult (interp); + fqn = Tcl_DuplicateObj (fqn); + Tcl_IncrRefCount (fqn); + + if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { + Tcl_AppendToObj (fqn, "::", -1); /* OK tcl9 */ + } + Tcl_AppendToObj (fqn, name, -1); /* OK tcl9 */ + } else { + fqn = Tcl_NewStringObj (name, -1); /* OK tcl9 */ + Tcl_IncrRefCount (fqn); + } + Tcl_ResetResult (interp); + + if (Tcl_GetCommandInfo (interp, + Tcl_GetString (fqn), + &ci)) { + Tcl_Obj* err; + + err = Tcl_NewObj (); + Tcl_AppendToObj (err, "command \"", -1); /* OK tcl9 */ + Tcl_AppendObjToObj (err, fqn); + Tcl_AppendToObj (err, "\" already exists, unable to create tree", -1); /* OK tcl9 */ + + Tcl_DecrRefCount (fqn); + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + if (objc == 4) { + Tcl_Obj* type = objv[2]; + Tcl_Obj* src = objv[3]; + int srctype; + + static CONST char* types [] = { + ":=", "=", "as", "deserialize", NULL + }; + enum types { + T_ASSIGN, T_IS, T_AS, T_DESER + }; + + if (Tcl_GetIndexFromObj (interp, type, types, "type", + 0, &srctype) != TCL_OK) { + Tcl_DecrRefCount (fqn); + Tcl_ResetResult (interp); + Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ + return TCL_ERROR; + } + + td = t_new (); + + switch (srctype) { + case T_ASSIGN: + case T_AS: + case T_IS: + if (tms_assign (interp, td, src) != TCL_OK) { + t_delete (td); + Tcl_DecrRefCount (fqn); + return TCL_ERROR; + } + break; + + case T_DESER: + if (t_deserialize (td, interp, src) != TCL_OK) { + t_delete (td); + Tcl_DecrRefCount (fqn); + return TCL_ERROR; + } + break; + } + } else { + td = t_new (); + } + + td->cmd = Tcl_CreateObjCommand2 (interp, Tcl_GetString (fqn), + tms_objcmd, (ClientData) td, + TDdeleteCmd); + + Tcl_SetObjResult (interp, fqn); + Tcl_DecrRefCount (fqn); + return TCL_OK; + } + + namespace eval tree { + critcl::ccommand prune_critcl {dummy interp objc objv} { + return 5; + } + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/tree_tcl.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/tree_tcl.tcl new file mode 100644 index 00000000..303c2d0e --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/struct/tree_tcl.tcl @@ -0,0 +1,2442 @@ +# tree.tcl -- +# +# Implementation of a tree data structure for Tcl. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: tree_tcl.tcl,v 1.5 2009/06/22 18:21:59 andreas_kupries Exp $ + +package require Tcl 8.5 9 +package require struct::list + +namespace eval ::struct::tree { + # Data storage in the tree module + # ------------------------------- + # + # There's a lot of bits to keep track of for each tree: + # nodes + # node values + # node relationships + # + # It would quickly become unwieldy to try to keep these in arrays or lists + # within the tree namespace itself. Instead, each tree structure will get + # its own namespace. Each namespace contains: + # children array mapping nodes to their children list + # parent array mapping nodes to their parent node + # node:$node array mapping keys to values for the node $node + + # counter is used to give a unique name for unnamed trees + variable counter 0 + + # Only export one command, the one used to instantiate a new tree + namespace export tree_tcl +} + +# ::struct::tree::tree_tcl -- +# +# Create a new tree with a given name; if no name is given, use +# treeX, where X is a number. +# +# Arguments: +# name Optional name of the tree; if null or not given, generate one. +# +# Results: +# name Name of the tree created + +proc ::struct::tree::tree_tcl {args} { + variable counter + + set src {} + set srctype {} + + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "tree${counter}" + } + 2 { + # Standard call. New empty tree. + set name [lindex $args 0] + } + 4 { + # Copy construction. + foreach {name as src} $args break + switch -exact -- $as { + = - := - as { + set srctype tree + } + deserialize { + set srctype serial + } + default { + return -code error \ + "wrong # args: should be \"tree ?name ?=|:=|as|deserialize source??\"" + } + } + } + default { + # Error. + return -code error \ + "wrong # args: should be \"tree ?name ?=|:=|as|deserialize source??\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + if {[llength [info commands $name]]} { + return -code error \ + "command \"$name\" already exists, unable to create tree" + } + + # Set up the namespace for the object, + # identical to the object command. + namespace eval $name { + variable rootname + set rootname root + + # Set up root node's child list + variable children + set children(root) [list] + + # Set root node's parent + variable parent + set parent(root) [list] + + # Set up the node attribute mapping + variable attribute + array set attribute {} + + # Set up a counter for use in creating unique node names + variable nextUnusedNode + set nextUnusedNode 1 + + # Set up a counter for use in creating node attribute arrays. + variable nextAttr + set nextAttr 0 + } + + # Create the command to manipulate the tree + interp alias {} $name {} ::struct::tree::TreeProc $name + + # Automatic execution of assignment if a source + # is present. + if {$src != {}} { + switch -exact -- $srctype { + tree { + set code [catch {_= $name $src} msg] + if {$code} { + namespace delete $name + interp alias {} $name {} + return -code $code -errorinfo $::errorInfo -errorcode $::errorCode $msg + } + } + serial { + set code [catch {_deserialize $name $src} msg] + if {$code} { + namespace delete $name + interp alias {} $name {} + return -code $code -errorinfo $::errorInfo -errorcode $::errorCode $msg + } + } + default { + return -code error \ + "Internal error, illegal srctype \"$srctype\"" + } + } + } + + # Give object to caller for use. + return $name +} + +# ::struct::tree::prune_tcl -- +# +# Abort the walk script, and ignore any children of the +# node we are currently at. +# +# Arguments: +# None. +# +# Results: +# None. +# +# Sideeffects: +# +# Stops the execution of the script and throws a signal to the +# surrounding walker to go to the next node, and ignore the +# children of the current node. + +proc ::struct::tree::prune_tcl {} { + return -code 5 +} + +########################## +# Private functions follow + +# ::struct::tree::TreeProc -- +# +# Command that processes all tree object commands. +# +# Arguments: +# name Name of the tree object to manipulate. +# cmd Subcommand to invoke. +# args Arguments for subcommand. +# +# Results: +# Varies based on command to perform + +proc ::struct::tree::TreeProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub _$cmd + if { [llength [info commands ::struct::tree::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::tree::_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 1 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + + set code [catch {uplevel 1 [linsert $args 0 ::struct::tree::$sub $name]} result] + + if {$code == 1} { + return -errorinfo [ErrorInfoAsCaller uplevel $sub] \ + -errorcode $::errorCode -code error $result + } elseif {$code == 2} { + return -code $code $result + } + return $result +} + +# ::struct::tree::_:= -- +# +# Assignment operator. Copies the source tree into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the tree object we are copying into. +# source Name of the tree object providing us with the +# data to copy. +# +# Results: +# Nothing. + +proc ::struct::tree::_= {name source} { + _deserialize $name [$source serialize] + return +} + +# ::struct::tree::_--> -- +# +# Reverse assignment operator. Copies this tree into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the tree object to copy +# dest Name of the tree object we are copying to. +# +# Results: +# Nothing. + +proc ::struct::tree::_--> {name dest} { + $dest deserialize [_serialize $name] + return +} + +# ::struct::tree::_ancestors -- +# +# Return the list of all parent nodes of a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to look up. +# +# Results: +# parents List of parents of node $node. +# Immediate ancestor (parent) first, +# Root of tree (ancestor of all) last. + +proc ::struct::tree::_ancestors {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + set a {} + while {[info exists parent($node)]} { + set node $parent($node) + if {$node == {}} break + lappend a $node + } + return $a +} + +# ::struct::tree::_attr -- +# +# Return attribute data for one key and multiple nodes, possibly all. +# +# Arguments: +# name Name of the tree object. +# key Name of the attribute to retrieve. +# +# Results: +# children Dictionary mapping nodes to attribute data. + +proc ::struct::tree::_attr {name key args} { + # Syntax: + # + # t attr key + # t attr key -nodes {nodelist} + # t attr key -glob nodepattern + # t attr key -regexp nodepattern + + variable ${name}::attribute + + set usage "wrong # args: should be \"[list $name] attr key ?-nodes list|-glob pattern|-regexp pattern?\"" + if {([llength $args] != 0) && ([llength $args] != 2)} { + return -code error $usage + } elseif {[llength $args] == 0} { + # This automatically restricts the list + # to nodes which can have the attribute + # in question. + + set nodes [array names attribute] + } else { + # Determine a list of nodes to look at + # based on the chosen restriction. + + foreach {mode value} $args break + switch -exact -- $mode { + -nodes { + # This is the only branch where we have to + # perform an explicit restriction to the + # nodes which have attributes. + set nodes {} + foreach n $value { + if {![info exists attribute($n)]} continue + lappend nodes $n + } + } + -glob { + set nodes [array names attribute $value] + } + -regexp { + set nodes {} + foreach n [array names attribute] { + if {![regexp -- $value $n]} continue + lappend nodes $n + } + } + default { + return -code error $usage + } + } + } + + # Without possibly matching nodes + # the result has to be empty. + + if {![llength $nodes]} { + return {} + } + + # Now locate matching keys and their values. + + set result {} + foreach n $nodes { + upvar ${name}::$attribute($n) data + if {[info exists data($key)]} { + lappend result $n $data($key) + } + } + + return $result +} + +# ::struct::tree::_deserialize -- +# +# Assignment operator. Copies a serialization into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the tree object we are copying into. +# serial Serialized tree to copy from. +# +# Results: +# Nothing. + +proc ::struct::tree::_deserialize {name serial} { + # As we destroy the original tree as part of + # the copying process we don't have to deal + # with issues like node names from the new tree + # interfering with the old ... + + # I. Get the serialization of the source tree + # and check it for validity. + + CheckSerialization $serial attr p c rn + + # Get all the relevant data into the scope + + variable ${name}::rootname + variable ${name}::children + variable ${name}::parent + variable ${name}::attribute + variable ${name}::nextAttr + + # Kill the existing parent/children information and insert the new + # data in their place. + + foreach n [array names parent] { + unset parent($n) children($n) + } + array set parent [array get p] + array set children [array get c] + unset p c + + set nextAttr 0 + foreach a [array names attribute] { + unset ${name}::$attribute($a) + } + foreach n [array names attr] { + GenAttributeStorage $name $n + array set ${name}::$attribute($n) $attr($n) + } + + set rootname $rn + + ## Debug ## Dump internals ... + if {0} { + puts "___________________________________ $name" + puts $rootname + parray children + parray parent + parray attribute + puts ___________________________________ + } + return +} + +# ::struct::tree::_children -- +# +# Return the list of children for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# children List of children for the node. + +proc ::struct::tree::_children {name args} { + # args := ?-all? node ?filter cmdprefix? + + # '-all' implies that not only the direct children of the + # node, but all their children, and so on, are returned. + # + # 'filter cmd' implies that only those nodes in the result list + # which pass the test 'cmd' are placed into the final result. + + set usage "wrong # args: should be \"[list $name] children ?-all? node ?filter cmd?\"" + + if {([llength $args] < 1) || ([llength $args] > 4)} { + return -code error $usage + } + if {[string equal [lindex $args 0] -all]} { + set all 1 + set args [lrange $args 1 end] + } else { + set all 0 + } + + # args := node ?filter cmdprefix? + + if {([llength $args] != 1) && ([llength $args] != 3)} { + return -code error $usage + } + if {[llength $args] == 3} { + foreach {node _const_ cmd} $args break + if {![string equal $_const_ filter] || ![llength $cmd]} { + return -code error $usage + } + } else { + set node [lindex $args 0] + set cmd {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + if {$all} { + set result [DescendantsCore $name $node] + } else { + variable ${name}::children + set result $children($node) + } + + if {[llength $cmd]} { + lappend cmd $name + set result [uplevel 1 [list ::struct::list filter $result $cmd]] + } + + return $result +} + +# ::struct::tree::_cut -- +# +# Destroys the specified node of a tree, but not its children. +# These children are made into children of the parent of the +# destroyed node at the index of the destroyed node. +# +# Arguments: +# name Name of the tree object. +# node Node to look up and cut. +# +# Results: +# None. + +proc ::struct::tree::_cut {name node} { + variable ${name}::rootname + + if { [string equal $node $rootname] } { + # Can't delete the special root node + return -code error "cannot cut root node" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + + # Locate our parent, children and our location in the parent + set parentNode $parent($node) + set childNodes $children($node) + + set index [lsearch -exact $children($parentNode) $node] + + # Excise this node from the parent list, + set newChildren [lreplace $children($parentNode) $index $index] + + # Put each of the children of $node into the parent's children list, + # in the place of $node, and update the parent pointer of those nodes. + foreach child $childNodes { + set newChildren [linsert $newChildren $index $child] + set parent($child) $parentNode + incr index + } + set children($parentNode) $newChildren + + KillNode $name $node + return +} + +# ::struct::tree::_delete -- +# +# Remove a node from a tree, including all of its values. Recursively +# removes the node's children. +# +# Arguments: +# name Name of the tree. +# node Node to delete. +# +# Results: +# None. + +proc ::struct::tree::_delete {name node} { + variable ${name}::rootname + if { [string equal $node $rootname] } { + # Can't delete the special root node + return -code error "cannot delete root node" + } + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + # Remove this node from its parent's children list + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + ldelete children($parentNode) $index + + # Yes, we could use the stack structure implemented in ::struct::stack, + # but it's slower than inlining it. Since we don't need a sophisticated + # stack, don't bother. + set st [list] + foreach child $children($node) { + lappend st $child + } + + KillNode $name $node + + while {[llength $st] > 0} { + set node [lindex $st end] + ldelete st end + foreach child $children($node) { + lappend st $child + } + + KillNode $name $node + } + return +} + +# ::struct::tree::_depth -- +# +# Return the depth (distance from the root node) of a given node. +# +# Arguments: +# name Name of the tree. +# node Node to find. +# +# Results: +# depth Number of steps from node to the root node. + +proc ::struct::tree::_depth {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + variable ${name}::parent + variable ${name}::rootname + set depth 0 + while { ![string equal $node $rootname] } { + incr depth + set node $parent($node) + } + return $depth +} + +# ::struct::tree::_descendants -- +# +# Return the list containing all descendants of a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to look at. +# +# Results: +# desc (filtered) List of nodes descending from 'node'. + +proc ::struct::tree::_descendants {name node args} { + # children -all sucessor, allows filtering. + + set usage "wrong # args: should be \"[list $name] descendants node ?filter cmd?\"" + + if {[llength $args] > 2} { + return -code error $usage + } elseif {[llength $args] == 2} { + foreach {_const_ cmd} $args break + if {![string equal $_const_ filter] || ![llength $cmd]} { + return -code error $usage + } + } else { + set cmd {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + set result [DescendantsCore $name $node] + + if {[llength $cmd]} { + lappend cmd $name + set result [uplevel 1 [list ::struct::list filter $result $cmd]] + } + + return $result +} + +proc ::struct::tree::DescendantsCore {name node} { + # CORE for listing of node descendants. + # No checks ... + # No filtering ... + + variable ${name}::children + + # New implementation. Instead of keeping a second, and explicit, + # list of pending nodes to shift through (= copying of array data + # around), we reuse the result list for that, using a counter and + # direct access to list elements to keep track of what nodes have + # not been handled yet. This eliminates a whole lot of array + # copying within the list implementation in the Tcl core. The + # result is unchanged, i.e. the nodes are in the same order as + # before. + + set result $children($node) + set at 0 + + while {$at < [llength $result]} { + set n [lindex $result $at] + incr at + foreach c $children($n) { + lappend result $c + } + } + + return $result +} + +# ::struct::tree::_destroy -- +# +# Destroy a tree, including its associated command and data storage. +# +# Arguments: +# name Name of the tree to destroy. +# +# Results: +# None. + +proc ::struct::tree::_destroy {name} { + namespace delete $name + interp alias {} $name {} +} + +# ::struct::tree::_exists -- +# +# Test for existence of a given node in a tree. +# +# Arguments: +# name Name of the tree to query. +# node Node to look for. +# +# Results: +# 1 if the node exists, 0 else. + +proc ::struct::tree::_exists {name node} { + return [info exists ${name}::parent($node)] +} + +# ::struct::tree::_get -- +# +# Get a keyed value from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# key Key to lookup. +# +# Results: +# value Value associated with the key given. + +proc ::struct::tree::_get {name node key} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, key has to be invalid. + return -code error "invalid key \"$key\" for node \"$node\"" + } + + upvar ${name}::$attribute($node) data + if {![info exists data($key)]} { + return -code error "invalid key \"$key\" for node \"$node\"" + } + return $data($key) +} + +# ::struct::tree::_getall -- +# +# Get a serialized list of key/value pairs from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# +# Results: +# value A serialized list of key/value pairs. + +proc ::struct::tree::_getall {name node {pattern *}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attributes ... + return {} + } + + upvar ${name}::$attribute($node) data + return [array get data $pattern] +} + +# ::struct::tree::_height -- +# +# Return the height (distance from the given node to its deepest child) +# +# Arguments: +# name Name of the tree. +# node Node we wish to know the height for.. +# +# Results: +# height Distance to deepest child of the node. + +proc ::struct::tree::_height {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + if {[llength $children($node)] == 0} { + # No children, is a leaf, height is 0. + return 0 + } + + # New implementation. We iteratively compute the height for each + # node under the specified one, from the bottom up. The previous + # implementation, using recursion will fail if the encountered + # subtree has a height greater than the currently set recursion + # limit. + + array set h {} + + # NOTE: Check out if a for loop doing direct access, i.e. without + # list reversal, is faster. + + foreach n [struct::list reverse [DescendantsCore $name $node]] { + # Height of leafs + if {![llength $children($n)]} {set h($n) 0} + + # Height of our parent is max of our and previous height. + set p $parent($n) + if {![info exists h($p)] || ($h($n) >= $h($p))} { + set h($p) [expr {$h($n) + 1}] + } + } + + # NOTE: Check out how much we gain by caching the result. + # For all nodes we have this computed. Use cache here + # as well to cut the inspection of descendants down. + # This may degenerate into a recursive solution again + # however. + + return $h($node) +} + +# ::struct::tree::_keys -- +# +# Get a list of keys from a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# +# Results: +# value A serialized list of key/value pairs. + +proc ::struct::tree::_keys {name node {pattern *}} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node. + return {} + } + + upvar ${name}::$attribute($node) data + return [array names data $pattern] +} + +# ::struct::tree::_keyexists -- +# +# Test for existence of a given key for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to query. +# key Key to lookup. +# +# Results: +# 1 if the key exists, 0 else. + +proc ::struct::tree::_keyexists {name node key} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, key cannot exist + return 0 + } + + upvar ${name}::$attribute($node) data + return [info exists data($key)] +} + +# ::struct::tree::_index -- +# +# Determine the index of node with in its parent's list of children. +# +# Arguments: +# name Name of the tree. +# node Node to look up. +# +# Results: +# index The index of the node in its parent + +proc ::struct::tree::_index {name node} { + variable ${name}::rootname + if { [string equal $node $rootname] } { + # The special root node has no parent, thus no index in it either. + return -code error "cannot determine index of root node" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + # Locate the parent and ourself in its list of children + set parentNode $parent($node) + + return [lsearch -exact $children($parentNode) $node] +} + +# ::struct::tree::_insert -- +# +# Add a node to a tree; if the node(s) specified already exist, they +# will be moved to the given location. +# +# Arguments: +# name Name of the tree. +# parentNode Parent to add the node to. +# index Index at which to insert. +# args Node(s) to insert. If none is given, the routine +# will insert a single node with a unique name. +# +# Results: +# nodes List of nodes inserted. + +proc ::struct::tree::_insert {name parentNode index args} { + if { [llength $args] == 0 } { + # No node name was given; generate a unique one + set args [list [GenerateUniqueNodeName $name]] + } + if { ![_exists $name $parentNode] } { + return -code error "parent node \"$parentNode\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + variable ${name}::rootname + + # Make sure the index is numeric + + if {[string equal $index "end"]} { + set index [llength $children($parentNode)] + } elseif {[regexp {^end-([0-9]+)$} $index -> n]} { + set index [expr {[llength $children($parentNode)] - $n}] + } + + foreach node $args { + if {[_exists $name $node] } { + # Move the node to its new home + if { [string equal $node $rootname] } { + return -code error "cannot move root node" + } + + # Cannot make a node its own descendant (I'm my own grandpa...) + set ancestor $parentNode + while { ![string equal $ancestor $rootname] } { + if { [string equal $ancestor $node] } { + return -code error "node \"$node\" cannot be its own descendant" + } + set ancestor $parent($ancestor) + } + # Remove this node from its parent's children list + set oldParent $parent($node) + set ind [lsearch -exact $children($oldParent) $node] + ldelete children($oldParent) $ind + + # If the node is moving within its parent, and its old location + # was before the new location, decrement the new location, so that + # it gets put in the right spot + if { [string equal $oldParent $parentNode] && $ind < $index } { + incr index -1 + } + } else { + # Set up the new node + set children($node) [list] + } + + # Add this node to its parent's children list + set children($parentNode) [linsert $children($parentNode) $index $node] + + # Update the parent pointer for this node + set parent($node) $parentNode + incr index + } + + return $args +} + +# ::struct::tree::_isleaf -- +# +# Return whether the given node of a tree is a leaf or not. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# isleaf True if the node is a leaf; false otherwise. + +proc ::struct::tree::_isleaf {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + return [expr {[llength $children($node)] == 0}] +} + +# ::struct::tree::_move -- +# +# Move a node (and all its subnodes) from where ever it is to a new +# location in the tree. +# +# Arguments: +# name Name of the tree +# parentNode Parent to add the node to. +# index Index at which to insert. +# node Node to move; the node must exist in the tree. +# args Additional nodes to move; these nodes must exist +# in the tree. +# +# Results: +# None. + +proc ::struct::tree::_move {name parentNode index node args} { + set args [linsert $args 0 $node] + + # Can only move a node to a real location in the tree + if { ![_exists $name $parentNode] } { + return -code error "parent node \"$parentNode\" does not exist in tree \"$name\"" + } + + variable ${name}::parent + variable ${name}::children + variable ${name}::rootname + + # Make sure the index is numeric + + if {[string equal $index "end"]} { + set index [llength $children($parentNode)] + } elseif {[regexp {^end-([0-9]+)$} $index -> n]} { + set index [expr {[llength $children($parentNode)] - $n}] + } + + # Validate all nodes to move before trying to move any. + foreach node $args { + if { [string equal $node $rootname] } { + return -code error "cannot move root node" + } + + # Can only move real nodes + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Cannot move a node to be a descendant of itself + set ancestor $parentNode + while { ![string equal $ancestor $rootname] } { + if { [string equal $ancestor $node] } { + return -code error "node \"$node\" cannot be its own descendant" + } + set ancestor $parent($ancestor) + } + } + + # Remove all nodes from their current parent's children list + foreach node $args { + set oldParent $parent($node) + set ind [lsearch -exact $children($oldParent) $node] + + ldelete children($oldParent) $ind + + # Update the nodes parent value + set parent($node) $parentNode + } + + # Add all nodes to their new parent's children list + set children($parentNode) \ + [eval [list linsert $children($parentNode) $index] $args] + + return +} + +# ::struct::tree::_next -- +# +# Return the right sibling for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to retrieve right sibling for. +# +# Results: +# sibling The right sibling for the node, or null if node was +# the rightmost child of its parent. + +proc ::struct::tree::_next {name node} { + # The 'root' has no siblings. + variable ${name}::rootname + if { [string equal $node $rootname] } { + return {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Locate the parent and our place in its list of children. + variable ${name}::parent + variable ${name}::children + + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + + # Go to the node to the right and return its name. + return [lindex $children($parentNode) [incr index]] +} + +# ::struct::tree::_numchildren -- +# +# Return the number of immediate children for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# numchildren Number of immediate children for the node. + +proc ::struct::tree::_numchildren {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::children + return [llength $children($node)] +} + +# ::struct::tree::_nodes -- +# +# Return a list containing all nodes known to the tree. +# +# Arguments: +# name Name of the tree object. +# +# Results: +# nodes List of nodes in the tree. + +proc ::struct::tree::_nodes {name} { + variable ${name}::children + return [array names children] +} + +# ::struct::tree::_parent -- +# +# Return the name of the parent node of a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to look up. +# +# Results: +# parent Parent of node $node + +proc ::struct::tree::_parent {name node} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + # FRINK: nocheck + return [set ${name}::parent($node)] +} + +# ::struct::tree::_previous -- +# +# Return the left sibling for a given node of a tree. +# +# Arguments: +# name Name of the tree object. +# node Node to look up. +# +# Results: +# sibling The left sibling for the node, or null if node was +# the leftmost child of its parent. + +proc ::struct::tree::_previous {name node} { + # The 'root' has no siblings. + variable ${name}::rootname + if { [string equal $node $rootname] } { + return {} + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Locate the parent and our place in its list of children. + variable ${name}::parent + variable ${name}::children + + set parentNode $parent($node) + set index [lsearch -exact $children($parentNode) $node] + + # Go to the node to the right and return its name. + return [lindex $children($parentNode) [incr index -1]] +} + +# ::struct::tree::_rootname -- +# +# Query or change the name of the root node. +# +# Arguments: +# name Name of the tree. +# +# Results: +# The name of the root node + +proc ::struct::tree::_rootname {name} { + variable ${name}::rootname + return $rootname +} + +# ::struct::tree::_rename -- +# +# Change the name of any node. +# +# Arguments: +# name Name of the tree. +# node Name of node to be renamed +# newname New name for the node. +# +# Results: +# The new name of the node. + +proc ::struct::tree::_rename {name node newname} { + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + if {[_exists $name $newname]} { + return -code error "unable to rename node to \"$newname\",\ + node of that name already present in the tree \"$name\"" + } + + set oldname $node + + # Perform the rename in the internal + # data structures. + + variable ${name}::rootname + variable ${name}::children + variable ${name}::parent + variable ${name}::attribute + + set children($newname) $children($oldname) + unset children($oldname) + set parent($newname) $parent($oldname) + unset parent($oldname) + + foreach c $children($newname) { + set parent($c) $newname + } + + if {[string equal $oldname $rootname]} { + set rootname $newname + } else { + set p $parent($newname) + set pos [lsearch -exact $children($p) $oldname] + lset children($p) $pos $newname + } + + if {[info exists attribute($oldname)]} { + set attribute($newname) $attribute($oldname) + unset attribute($oldname) + } + + return $newname +} + +# ::struct::tree::_serialize -- +# +# Serialize a tree object (partially) into a transportable value. +# +# Arguments: +# name Name of the tree. +# node Root node of the serialized tree. +# +# Results: +# A list structure describing the part of the tree which was serialized. + +proc ::struct::tree::_serialize {name args} { + if {[llength $args] > 1} { + return -code error \ + "wrong # args: should be \"[list $name] serialize ?node?\"" + } elseif {[llength $args] == 1} { + set node [lindex $args 0] + + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + } else { + variable ${name}::rootname + set node $rootname + } + + set tree [list] + Serialize $name $node tree + return $tree +} + +# ::struct::tree::_set -- +# +# Set or get a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify or query. +# args Optional argument specifying a value. +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_set {name node key args} { + if {[llength $args] > 1} { + return -code error "wrong # args: should be \"$name set node key\ + ?value?\"" + } + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + # Process the arguments ... + + if {[llength $args] > 0} { + # Setting the value. This may have to create + # the attribute array for this particular + # node + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it now. + GenAttributeStorage $name $node + } + upvar ${name}::$attribute($node) data + + return [set data($key) [lindex $args end]] + } else { + # Getting the value + + return [_get $name $node $key] + } +} + +# ::struct::tree::_append -- +# +# Append a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify. +# key Name of attribute to modify. +# value Value to append +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_append {name node key value} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name $node + } + + upvar ${name}::$attribute($node) data + return [append data($key) $value] +} + +# ::struct::tree::_lappend -- +# +# lappend a value for a node in a tree. +# +# Arguments: +# name Name of the tree. +# node Node to modify or query. +# key Name of attribute to modify. +# value Value to append +# +# Results: +# val Value associated with the given key of the given node + +proc ::struct::tree::_lappend {name node key value} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # so create it as we need it. + GenAttributeStorage $name $node + } + + upvar ${name}::$attribute($node) data + return [lappend data($key) $value] +} + +# ::struct::tree::_leaves -- +# +# Return a list containing all leaf nodes known to the tree. +# +# Arguments: +# name Name of the tree object. +# +# Results: +# nodes List of leaf nodes in the tree. + +proc ::struct::tree::_leaves {name} { + variable ${name}::children + + set res {} + foreach n [array names children] { + if {[llength $children($n)]} continue + lappend res $n + } + return $res +} + +# ::struct::tree::_size -- +# +# Return the number of descendants of a given node. The default node +# is the special root node. +# +# Arguments: +# name Name of the tree. +# node Optional node to start counting from (default is root). +# +# Results: +# size Number of descendants of the node. + +proc ::struct::tree::_size {name args} { + variable ${name}::rootname + if {[llength $args] > 1} { + return -code error \ + "wrong # args: should be \"[list $name] size ?node?\"" + } elseif {[llength $args] == 1} { + set node [lindex $args 0] + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + } else { + # If the node is the root, we can do the cheap thing and just count the + # number of nodes (excluding the root node) that we have in the tree with + # array size. + + return [expr {[array size ${name}::parent] - 1}] + } + + # If the node is the root, we can do the cheap thing and just count the + # number of nodes (excluding the root node) that we have in the tree with + # array size. + + if { [string equal $node $rootname] } { + return [expr {[array size ${name}::parent] - 1}] + } + + # Otherwise we have to do it the hard way and do a full tree search + variable ${name}::children + set size 0 + set st [list ] + foreach child $children($node) { + lappend st $child + } + while { [llength $st] > 0 } { + set node [lindex $st end] + ldelete st end + incr size + foreach child $children($node) { + lappend st $child + } + } + return $size +} + +# ::struct::tree::_splice -- +# +# Add a node to a tree, making a range of children from the given +# parent children of the new node. +# +# Arguments: +# name Name of the tree. +# parentNode Parent to add the node to. +# from Index at which to insert. +# to Optional end of the range of children to replace. +# Defaults to 'end'. +# args Optional node name; if given, must be unique. If not +# given, a unique name will be generated. +# +# Results: +# node Name of the node added to the tree. + +proc ::struct::tree::_splice {name parentNode from {to end} args} { + + if { ![_exists $name $parentNode] } { + return -code error "node \"$parentNode\" does not exist in tree \"$name\"" + } + + if { [llength $args] == 0 } { + # No node name given; generate a unique node name + set node [GenerateUniqueNodeName $name] + } else { + set node [lindex $args 0] + } + + if { [_exists $name $node] } { + return -code error "node \"$node\" already exists in tree \"$name\"" + } + + variable ${name}::children + variable ${name}::parent + + if {[string equal $from "end"]} { + set from [expr {[llength $children($parentNode)] - 1}] + } elseif {[regexp {^end-([0-9]+)$} $from -> n]} { + set from [expr {[llength $children($parentNode)] - 1 - $n}] + } + if {[string equal $to "end"]} { + set to [expr {[llength $children($parentNode)] - 1}] + } elseif {[regexp {^end-([0-9]+)$} $to -> n]} { + set to [expr {[llength $children($parentNode)] - 1 - $n}] + } + + # Save the list of children that are moving + set moveChildren [lrange $children($parentNode) $from $to] + + # Remove those children from the parent + ldelete children($parentNode) $from $to + + # Add the new node + _insert $name $parentNode $from $node + + # Move the children + set children($node) $moveChildren + foreach child $moveChildren { + set parent($child) $node + } + + return $node +} + +# ::struct::tree::_swap -- +# +# Swap two nodes in a tree. +# +# Arguments: +# name Name of the tree. +# node1 First node to swap. +# node2 Second node to swap. +# +# Results: +# None. + +proc ::struct::tree::_swap {name node1 node2} { + # Can't swap the magic root node + variable ${name}::rootname + if {[string equal $node1 $rootname] || [string equal $node2 $rootname]} { + return -code error "cannot swap root node" + } + + # Can only swap two real nodes + if {![_exists $name $node1]} { + return -code error "node \"$node1\" does not exist in tree \"$name\"" + } + if {![_exists $name $node2]} { + return -code error "node \"$node2\" does not exist in tree \"$name\"" + } + + # Can't swap a node with itself + if {[string equal $node1 $node2]} { + return -code error "cannot swap node \"$node1\" with itself" + } + + # Swapping nodes means swapping their labels and values + variable ${name}::children + variable ${name}::parent + + set parent1 $parent($node1) + set parent2 $parent($node2) + + # Replace node1 with node2 in node1's parent's children list, and + # node2 with node1 in node2's parent's children list + set i1 [lsearch -exact $children($parent1) $node1] + set i2 [lsearch -exact $children($parent2) $node2] + + lset children($parent1) $i1 $node2 + lset children($parent2) $i2 $node1 + + # Make node1 the parent of node2's children, and vis versa + foreach child $children($node2) { + set parent($child) $node1 + } + foreach child $children($node1) { + set parent($child) $node2 + } + + # Swap the children lists + set children1 $children($node1) + set children($node1) $children($node2) + set children($node2) $children1 + + if { [string equal $node1 $parent2] } { + set parent($node1) $node2 + set parent($node2) $parent1 + } elseif { [string equal $node2 $parent1] } { + set parent($node1) $parent2 + set parent($node2) $node1 + } else { + set parent($node1) $parent2 + set parent($node2) $parent1 + } + + return +} + +# ::struct::tree::_unset -- +# +# Remove a keyed value from a node. +# +# Arguments: +# name Name of the tree. +# node Node to modify. +# key Name of attribute to unset. +# +# Results: +# None. + +proc ::struct::tree::_unset {name node key} { + if {![_exists $name $node]} { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + variable ${name}::attribute + if {![info exists attribute($node)]} { + # No attribute data for this node, + # nothing to do. + return + } + + upvar ${name}::$attribute($node) data + catch {unset data($key)} + + if {[array size data] == 0} { + # No attributes stored for this node, squash the whole array. + unset attribute($node) + unset data + } + return +} + +# ::struct::tree::_walk -- +# +# Walk a tree using a pre-order depth or breadth first +# search. Pre-order DFS is the default. At each node that is visited, +# a command will be called with the name of the tree and the node. +# +# Arguments: +# name Name of the tree. +# node Node at which to start. +# args Optional additional arguments specifying the type and order of +# the tree walk, and the command to execute at each node. +# Format is +# ?-type {bfs|dfs}? ?-order {pre|post|in|both}? a n script +# +# Results: +# None. + +proc ::struct::tree::_walk {name node args} { + set usage "$name walk node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? loopvar script" + + if {[llength $args] > 7 || [llength $args] < 2} { + return -code error "wrong # args: should be \"$usage\"" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + set args [WalkOptions $args 2 $usage] + # Remainder is 'a n script' + + foreach {loopvariables script} $args break + + if {[llength $loopvariables] > 2} { + return -code error "too many loop variables, at most two allowed" + } elseif {[llength $loopvariables] == 2} { + foreach {avar nvar} $loopvariables break + } else { + set nvar [lindex $loopvariables 0] + set avar {} + } + + # Make sure we have a script to run, otherwise what's the point? + if { [string equal $script ""] } { + return -code error "no script specified, or empty" + } + + # Do the walk + variable ${name}::children + set st [list ] + lappend st $node + + # Compute some flags for the possible places of command evaluation + set leave [expr {[string equal $order post] || [string equal $order both]}] + set enter [expr {[string equal $order pre] || [string equal $order both]}] + set touch [string equal $order in] + + if {$leave} { + set lvlabel leave + } elseif {$touch} { + # in-order does not provide a sense + # of nesting for the parent, hence + # no enter/leave, just 'visit'. + set lvlabel visit + } + + set rcode 0 + set rvalue {} + + if {[string equal $type "dfs"]} { + # Depth-first walk, several orders of visiting nodes + # (pre, post, both, in) + + array set visited {} + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are looking at this 'node'. + # Pop it, then evaluate the command (post, both, in). + + ldelete st end + + if {$leave || $touch} { + # Evaluate the script at this node + WalkCall $avar $nvar $name $node $lvlabel $script + # prune stops execution of loop here. + } + } else { + # First visit of this 'node'. + # Do *not* pop it from the stack so that we are able + # to visit again after its children + + # Remember it. + set visited($node) . + + if {$enter} { + # Evaluate the script at this node (pre, both). + # + # Note: As this is done before the children are + # looked at the script may change the children of + # this node and thus affect the walk. + + WalkCall $avar $nvar $name $node "enter" $script + # prune stops execution of loop here. + } + + # Add the children of this node to the stack. + # The exact behaviour depends on the chosen + # order. For pre, post, both-order we just + # have to add them in reverse-order so that + # they will be popped left-to-right. For in-order + # we have rearrange the stack so that the parent + # is revisited immediately after the first child. + # (but only if there is ore than one child,) + + set clist $children($node) + set len [llength $clist] + + if {$touch && ($len > 1)} { + # Pop node from stack, insert into list of children + ldelete st end + set clist [linsert $clist 1 $node] + incr len + } + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + lappend st [lindex $clist $i] + } + } + } + } else { + # Breadth first walk (pre, post, both) + # No in-order possible. Already captured. + + if {$leave} { + set backward $st + } + + while { [llength $st] > 0 } { + set node [lindex $st 0] + ldelete st 0 + + if {$enter} { + # Evaluate the script at this node + WalkCall $avar $nvar $name $node "enter" $script + # prune stops execution of loop here. + } + + # Add this node's children + # And create a mirrored version in case of post/both order. + + foreach child $children($node) { + lappend st $child + if {$leave} { + set backward [linsert $backward 0 $child] + } + } + } + + if {$leave} { + foreach node $backward { + # Evaluate the script at this node + WalkCall $avar $nvar $name $node "leave" $script + } + } + } + + if {$rcode != 0} { + return -code $rcode $rvalue + } + return +} + +proc ::struct::tree::_walkproc {name node args} { + set usage "$name walkproc node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? cmdprefix" + + if {[llength $args] > 6 || [llength $args] < 1} { + return -code error "wrong # args: should be \"$usage\"" + } + + if { ![_exists $name $node] } { + return -code error "node \"$node\" does not exist in tree \"$name\"" + } + + set args [WalkOptions $args 1 $usage] + # Remainder is 'n cmdprefix' + + set script [lindex $args 0] + + # Make sure we have a script to run, otherwise what's the point? + if { ![llength $script] } { + return -code error "no script specified, or empty" + } + + # Do the walk + variable ${name}::children + set st [list ] + lappend st $node + + # Compute some flags for the possible places of command evaluation + set leave [expr {[string equal $order post] || [string equal $order both]}] + set enter [expr {[string equal $order pre] || [string equal $order both]}] + set touch [string equal $order in] + + if {$leave} { + set lvlabel leave + } elseif {$touch} { + # in-order does not provide a sense + # of nesting for the parent, hence + # no enter/leave, just 'visit'. + set lvlabel visit + } + + set rcode 0 + set rvalue {} + + if {[string equal $type "dfs"]} { + # Depth-first walk, several orders of visiting nodes + # (pre, post, both, in) + + array set visited {} + + while { [llength $st] > 0 } { + set node [lindex $st end] + + if {[info exists visited($node)]} { + # Second time we are looking at this 'node'. + # Pop it, then evaluate the command (post, both, in). + + ldelete st end + + if {$leave || $touch} { + # Evaluate the script at this node + WalkCallProc $name $node $lvlabel $script + # prune stops execution of loop here. + } + } else { + # First visit of this 'node'. + # Do *not* pop it from the stack so that we are able + # to visit again after its children + + # Remember it. + set visited($node) . + + if {$enter} { + # Evaluate the script at this node (pre, both). + # + # Note: As this is done before the children are + # looked at the script may change the children of + # this node and thus affect the walk. + + WalkCallProc $name $node "enter" $script + # prune stops execution of loop here. + } + + # Add the children of this node to the stack. + # The exact behaviour depends on the chosen + # order. For pre, post, both-order we just + # have to add them in reverse-order so that + # they will be popped left-to-right. For in-order + # we have rearrange the stack so that the parent + # is revisited immediately after the first child. + # (but only if there is ore than one child,) + + set clist $children($node) + set len [llength $clist] + + if {$touch && ($len > 1)} { + # Pop node from stack, insert into list of children + ldelete st end + set clist [linsert $clist 1 $node] + incr len + } + + for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { + lappend st [lindex $clist $i] + } + } + } + } else { + # Breadth first walk (pre, post, both) + # No in-order possible. Already captured. + + if {$leave} { + set backward $st + } + + while { [llength $st] > 0 } { + set node [lindex $st 0] + ldelete st 0 + + if {$enter} { + # Evaluate the script at this node + WalkCallProc $name $node "enter" $script + # prune stops execution of loop here. + } + + # Add this node's children + # And create a mirrored version in case of post/both order. + + foreach child $children($node) { + lappend st $child + if {$leave} { + set backward [linsert $backward 0 $child] + } + } + } + + if {$leave} { + foreach node $backward { + # Evaluate the script at this node + WalkCallProc $name $node "leave" $script + } + } + } + + if {$rcode != 0} { + return -code $rcode $rvalue + } + return +} + +proc ::struct::tree::WalkOptions {theargs n usage} { + upvar 1 type type order order + + # Set defaults + set type dfs + set order pre + + while {[llength $theargs]} { + set flag [lindex $theargs 0] + switch -exact -- $flag { + "-type" { + if {[llength $theargs] < 2} { + return -code error "value for \"$flag\" missing" + } + set type [string tolower [lindex $theargs 1]] + set theargs [lrange $theargs 2 end] + } + "-order" { + if {[llength $theargs] < 2} { + return -code error "value for \"$flag\" missing" + } + set order [string tolower [lindex $theargs 1]] + set theargs [lrange $theargs 2 end] + } + "--" { + set theargs [lrange $theargs 1 end] + break + } + default { + break + } + } + } + + if {[llength $theargs] == 0} { + return -code error "wrong # args: should be \"$usage\"" + } + if {[llength $theargs] != $n} { + return -code error "unknown option \"$flag\"" + } + + # Validate that the given type is good + switch -exact -- $type { + "dfs" - "bfs" { + set type $type + } + default { + return -code error "bad search type \"$type\": must be bfs or dfs" + } + } + + # Validate that the given order is good + switch -exact -- $order { + "pre" - "post" - "in" - "both" { + set order $order + } + default { + return -code error "bad search order \"$order\":\ + must be both, in, pre, or post" + } + } + + if {[string equal $order "in"] && [string equal $type "bfs"]} { + return -code error "unable to do a ${order}-order breadth first walk" + } + + return $theargs +} + +# ::struct::tree::WalkCall -- +# +# Helper command to 'walk' handling the evaluation +# of the user-specified command. Information about +# the tree, node and current action are substituted +# into the command before it evaluation. +# +# Arguments: +# tree Tree we are walking +# node Node we are at. +# action The current action. +# cmd The command to call, already partially substituted. +# +# Results: +# None. + +proc ::struct::tree::WalkCall {avar nvar tree node action cmd} { + + if {$avar != {}} { + upvar 2 $avar a ; set a $action + } + upvar 2 $nvar n ; set n $node + + set code [catch {uplevel 2 $cmd} result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # 5 - the body invoked [struct::tree::prune] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel WalkCall] \ + -errorcode $::errorCode -code error $result + } + 3 { + # FRINK: nocheck + return -code break + } + 4 {} + 5 { + upvar order order + if {[string equal $order post] || [string equal $order in]} { + return -code error "Illegal attempt to prune ${order}-order walking" + } + return -code continue + } + default { + upvar 1 rcode rcode rvalue rvalue + set rcode $code + set rvalue $result + return -code break + #return -code $code $result + } + } + return {} +} + +proc ::struct::tree::WalkCallProc {tree node action cmd} { + + lappend cmd $tree $node $action + set code [catch {uplevel 2 $cmd} result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # 5 - the body invoked [struct::tree::prune] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel WalkCallProc] \ + -errorcode $::errorCode -code error $result + } + 3 { + # FRINK: nocheck + return -code break + } + 4 {} + 5 { + upvar order order + if {[string equal $order post] || [string equal $order in]} { + return -code error "Illegal attempt to prune ${order}-order walking" + } + return -code continue + } + default { + upvar 1 rcode rcode rvalue rvalue + set rcode $code + set rvalue $result + return -code break + } + } + return {} +} + +proc ::struct::tree::ErrorInfoAsCaller {find replace} { + set info $::errorInfo + set i [string last "\n (\"$find" $info] + if {$i == -1} {return $info} + set result [string range $info 0 [incr i 6]] ;# keep "\n (\"" + append result $replace ;# $find -> $replace + incr i [string length $find] + set j [string first ) $info [incr i]] ;# keep rest of parenthetical + append result [string range $info $i $j] + return $result +} + +# ::struct::tree::GenerateUniqueNodeName -- +# +# Generate a unique node name for the given tree. +# +# Arguments: +# name Name of the tree to generate a unique node name for. +# +# Results: +# node Name of a node guaranteed to not exist in the tree. + +proc ::struct::tree::GenerateUniqueNodeName {name} { + variable ${name}::nextUnusedNode + while {[_exists $name "node${nextUnusedNode}"]} { + incr nextUnusedNode + } + return "node${nextUnusedNode}" +} + +# ::struct::tree::KillNode -- +# +# Delete all data of a node. +# +# Arguments: +# name Name of the tree containing the node +# node Name of the node to delete. +# +# Results: +# none + +proc ::struct::tree::KillNode {name node} { + variable ${name}::parent + variable ${name}::children + variable ${name}::attribute + + # Remove all record of $node + unset parent($node) + unset children($node) + + if {[info exists attribute($node)]} { + # FRINK: nocheck + unset ${name}::$attribute($node) + unset attribute($node) + } + return +} + +# ::struct::tree::GenAttributeStorage -- +# +# Create an array to store the attributes of a node in. +# +# Arguments: +# name Name of the tree containing the node +# node Name of the node which got attributes. +# +# Results: +# none + +proc ::struct::tree::GenAttributeStorage {name node} { + variable ${name}::nextAttr + variable ${name}::attribute + + set attr "a[incr nextAttr]" + set attribute($node) $attr + return +} + +# ::struct::tree::Serialize -- +# +# Serialize a tree object (partially) into a transportable value. +# +# Arguments: +# name Name of the tree. +# node Root node of the serialized tree. +# +# Results: +# None + +proc ::struct::tree::Serialize {name node tvar} { + upvar 1 $tvar tree + + variable ${name}::attribute + variable ${name}::parent + + # 'node' is the root of the tree to serialize. The precondition + # for the call is that this node is already stored in the list + # 'tvar', at index 'rootidx'. + + # The attribute data for 'node' goes immediately after the 'node' + # data. the node information is _not_ yet stored, and this command + # has to do this. + + + array set r {} + set loc($node) 0 + + lappend tree $node {} + if {[info exists attribute($node)]} { + upvar ${name}::$attribute($node) data + lappend tree [array get data] + } else { + # Encode nodes without attributes. + lappend tree {} + } + + foreach n [DescendantsCore $name $node] { + set loc($n) [llength $tree] + lappend tree $n $loc($parent($n)) + + if {[info exists attribute($n)]} { + upvar ${name}::$attribute($n) data + lappend tree [array get data] + } else { + # Encode nodes without attributes. + lappend tree {} + } + } + + return $tree +} + + +proc ::struct::tree::CheckSerialization {ser avar pvar cvar rnvar} { + upvar 1 $avar attr $pvar p $cvar ch $rnvar rn + + # Overall length ok ? + + if {[llength $ser] % 3} { + return -code error \ + "error in serialization: list length not a multiple of 3." + } + + set rn {} + array set p {} + array set ch {} + array set attr {} + + # Basic decoder pass + + foreach {node parent nattr} $ser { + + # Initialize children data, if not already done + if {![info exists ch($node)]} { + set ch($node) {} + } + # Attribute length ok ? Dictionary! + if {[llength $nattr] % 2} { + return -code error \ + "error in serialization: malformed attribute dictionary." + } + # Remember attribute data only for non-empty nodes + if {[llength $nattr]} { + set attr($node) $nattr + } + # Remember root + if {$parent == {}} { + lappend rn $node + set p($node) {} + continue + } + # Parent reference ok ? + if { + ![string is integer -strict $parent] || + ($parent % 3) || + ($parent < 0) || + ($parent >= [llength $ser]) + } { + return -code error \ + "error in serialization: bad parent reference \"$parent\"." + } + # Remember parent, and reconstruct children + + set p($node) [lindex $ser $parent] + lappend ch($p($node)) $node + } + + # Root node information ok ? + + if {[llength $rn] < 1} { + return -code error \ + "error in serialization: no root specified." + } elseif {[llength $rn] > 1} { + return -code error \ + "error in serialization: multiple root nodes." + } + set rn [lindex $rn 0] + + # Duplicate node names ? + + if {[array size ch] < ([llength $ser] / 3)} { + return -code error \ + "error in serialization: duplicate node names." + } + + # Cycles in the parent relationship ? + + array set visited {} + foreach n [array names p] { + if {[info exists visited($n)]} {continue} + array set _ {} + while {$n != {}} { + if {[info exists _($n)]} { + # Node already converted, cycle. + return -code error \ + "error in serialization: cycle detected." + } + set _($n) . + # root ? + if {$p($n) == {}} {break} + set n $p($n) + if {[info exists visited($n)]} {break} + set visited($n) . + } + unset _ + } + # Ok. The data is now ready for the caller. + + return +} + +########################## +# Private functions follow +# +# Do a compatibility version of [lset] for pre-8.4 versions of Tcl. +# This version does not do multi-arg [lset]! + +proc ::struct::tree::K { x y } { set x } + +if { [package vcompare [package provide Tcl] 8.4] < 0 } { + proc ::struct::tree::lset { var index arg } { + upvar 1 $var list + set list [::lreplace [K $list [set list {}]] $index $index $arg] + } +} + +proc ::struct::tree::ldelete {var index {end {}}} { + upvar 1 $var list + if {$end == {}} {set end $index} + set list [lreplace [K $list [set list {}]] $index $end] + return +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Put 'tree::tree' into the general structure namespace + # for pickup by the main management. + + namespace import -force tree::tree_tcl +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/ChangeLog b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/ChangeLog new file mode 100644 index 00000000..89a34bb0 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/ChangeLog @@ -0,0 +1,186 @@ +2013-11-22 Andreas Kupries + + * tar.man: Reviewed the work on the pyk-tar branch. Brought + * tar.tcl: new testsuite up to spec. Reviewed the skip fix, + * tar.test: modified it to reinstate the skip limit per round + * test-support.tcl: without getting the bug back. Bumped version + to 0.9. Thanks to PoorYorick for the initial work on the bug, + fix, and testsuite. This also fixes ticket [6b7aa0aecc]. + +2013-08-12 Andreas Kupries + + * tar.man (tar::untar, contents, stat, get): Extended the + * tar.tcl: procedures to detect and properly handle @LongName + * pkgIndex.tcl: header entries as generated by GNU tar. These + entries contain the file name for the next header entry as file + data, for files whose name is longer than the 100-char field of + the regular header. Version bumped to 0.8. This is a new + feature. + +2013-02-01 Andreas Kupries + + * + * Released and tagged Tcllib 1.15 ======================== + * + +2012-09-11 Andreas Kupries + + * tar.tcl (seekorskip): Fixed seekorskip which prevented its use + * pkgIndex.tcl: from a non-seekable channel, like stdin. The issue + was that the original attempt to seek before skipping not just + failed, but apparently still moved the read pointer in some way + which skipped over irreplacable input, breaking the next call of + readHeader. Using [tell] to check seekability does not break in + this manner. Bumped version to 0.7.1. + +2011-12-13 Andreas Kupries + + * + * Released and tagged Tcllib 1.14 ======================== + * + +2011-01-24 Andreas Kupries + + * + * Released and tagged Tcllib 1.13 ======================== + * + +2011-01-20 Andreas Kupries + + * tar.tcl: [Bug 3162548]: Applied patch by Alexandre Ferrieux, + * tar.man: extending various tar commands to be able to use + * pkgIndex.tcl: the -chan option, and channels instead of files. + Version bumped to 0.7 + +2009-12-07 Andreas Kupries + + * + * Released and tagged Tcllib 1.12 ======================== + * + +2009-12-03 Andreas Kupries + + * tar.man: [Patch 2840147]. Applied. New options -prefix and + * tar.tcl: -quick for tar::add. -prefix allows specifying a + * tar.pcx: prefix for filenames in the archive, and -quick 1 + * pkgIndex.tcl: changes back to the seek-from-end algorithm for + finding the place where to add the new files. The new default + scans from start (robust). Bumped version to 0.6. + +2009-05-12 Aaron Faupell + + * tar.tcl: add support for reading pre-posix archives. + if a file isnt writable when extracting, try deleting + before giving up. + +2008-12-12 Andreas Kupries + + * + * Released and tagged Tcllib 1.11.1 ======================== + * + +2008-11-26 Aaron Faupell + + * tar.man: add and clarify documentation + +2008-10-16 Andreas Kupries + + * + * Released and tagged Tcllib 1.11 ======================== + * + +2008-06-14 Andreas Kupries + + * tar.pcx: New file. Syntax definitions for the public commands of + the tar package. + +2007-09-12 Andreas Kupries + + * + * Released and tagged Tcllib 1.10 ======================== + * + +2007-03-21 Andreas Kupries + + * tar.man: Fixed all warnings due to use of now deprecated + commands. Added a section about how to give feedback. + +2007-02-08 Aaron Faupell + + * tar.tcl: bug fix in recursion algorithm that missed + some files in deep subdirs. incremented version + +2007-01-08 Andreas Kupries + + * tar.tcl: Bumped version to 0.3, for the bugfix described + * tar.man: by the last entry. + * pkgIndex.tcl: + +2006-12-20 Aaron Faupell + + * tar.tcl: fix in parseOpts which affected -file and -glob + arguments to tar::untar + * tar.man: clarifications to add, create, and untar + +2006-10-03 Andreas Kupries + + * + * Released and tagged Tcllib 1.9 ======================== + * + +2006-29-06 Aaron Faupell + + * tar.tcl: fixed bug in parseOpts + +2005-11-08 Andreas Kupries + + * pkgIndex.tcl: Corrected buggy commit, synchronized version + * tar.man: numbers across all relevant files. + +2005-11-08 Aaron Faupell + + * tar.tcl: bumped version to 0.2 because of new feature + * tar.man: tar::remove + +2005-11-07 Andreas Kupries + + * tar.man: Fixed error, incorrect placement of [call] markup + outside of list. + +2005-11-04 Aaron Faupell + + * tar.man: added tar::remove command and documentation for it + * tar.tcl: + +2005-10-06 Andreas Kupries + + * + * Released and tagged Tcllib 1.8 ======================== + * + +2005-09-30 Andreas Kupries + + * tar.tcl: qualified all [open] calls with :: to ensure usag of + the builtin. Apparently mitigates conflict between this package + and the vfs::tar module. + +2004-10-05 Andreas Kupries + + * + * Released and tagged Tcllib 1.7 ======================== + * + +2004-10-02 Andreas Kupries + + * tar.man: Added keywords and title/module description to the + documentation. + +2004-09-10 Aaron Faupell + + * tar.tcl: Fixed typo bug in ::tar::add + * tar.man: Added info for ::tar::stat + +2004-08-23 Andreas Kupries + + * tar.man: Fixed problems in the documentation. + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/pkgIndex.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/pkgIndex.tcl new file mode 100644 index 00000000..48836471 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/pkgIndex.tcl @@ -0,0 +1,5 @@ +if {![package vsatisfies [package provide Tcl] 8.5 9]} { + # PRAGMA: returnok + return +} +package ifneeded tar 0.12 [list source [file join $dir tar.tcl]] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tar.man b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tar.man new file mode 100644 index 00000000..5b406f82 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tar.man @@ -0,0 +1,202 @@ +[comment {-*- mode: tcl ; fill-column: 80 -*- doctools manpage}] +[vset PACKAGE_VERSION 0.12] +[manpage_begin tar n [vset PACKAGE_VERSION]] +[keywords archive] +[keywords {tape archive}] +[keywords tar] +[moddesc {Tar file handling}] +[titledesc {Tar file creation, extraction & manipulation}] +[category {File formats}] +[require Tcl "8.5 9"] +[require tar [opt [vset PACKAGE_VERSION]]] +[description] + +[para] [strong Note]: Starting with version 0.8 the tar reader commands +(contents, stats, get, untar) support the GNU LongName extension (header type +'L') for large paths. + +[para] + +[section BEWARE] + +For all commands, when using [option -chan] ... + +[list_begin enumerated] + +[enum] It is assumed that the channel was opened for reading, and configured for + binary input. + +[enum] It is assumed that the channel position is at the beginning of a legal + tar file. + +[enum] The commands will [emph modify] the channel position as they perform their + task. + +[enum] The commands will [emph not] close the channel. + +[enum] In other words, the commands leave the channel in a state very likely + unsuitable for use by further [cmd tar] commands. Still doing so will + very likely results in errors, bad data, etc. pp. + +[enum] It is the responsibility of the user to seek the channel back to a + suitable position. + +[enum] When using a channel transformation which is not generally seekable, for + example [cmd gunzip], then it is the responsibility of the user to (a) + unstack the transformation before seeking the channel back to a suitable + position, and (b) for restacking it after. + +[list_end] + +[section COMMANDS] + +[list_begin definitions] + +[call [cmd ::tar::contents] [arg tarball] [opt [option -chan]]] + +Returns a list of the files contained in [arg tarball]. The order is not sorted and depends on the order +files were stored in the archive. +[para] + +If the option [option -chan] is present [arg tarball] is interpreted as an open channel. +It is assumed that the channel was opened for reading, and configured for binary input. +The command will [emph not] close the channel. + +[call [cmd ::tar::stat] [arg tarball] [opt file] [opt [option -chan]]] + +Returns a nested dict containing information on the named [opt file] in [arg tarball], +or all files if none is specified. The top level are pairs of filename and info. The info is a dict with the keys +"[const mode] [const uid] [const gid] [const size] [const mtime] [const type] [const linkname] [const uname] [const gname] + [const devmajor] [const devminor]" + +[example { +% ::tar::stat tarball.tar +foo.jpg {mode 0644 uid 1000 gid 0 size 7580 mtime 811903867 type file linkname {} uname user gname wheel devmajor 0 devminor 0} +}] + +[para] +If the option [option -chan] is present [arg tarball] is interpreted as an open channel. +It is assumed that the channel was opened for reading, and configured for binary input. +The command will [emph not] close the channel. + +[call [cmd ::tar::untar] [arg tarball] [arg args]] + +Extracts [arg tarball]. [arg -file] and [arg -glob] limit the extraction +to files which exactly match or pattern match the given argument. No error is +thrown if no files match. Returns a list of filenames extracted and the file +size. The size will be null for non regular files. Leading path seperators are +stripped so paths will always be relative. + +[list_begin options] +[opt_def -dir dirName] +Directory to extract to. Uses [cmd pwd] if none is specified +[opt_def -file fileName] +Only extract the file with this name. The name is matched against the complete path +stored in the archive including directories. +[opt_def -glob pattern] +Only extract files patching this glob style pattern. The pattern is matched against the complete path +stored in the archive. +[opt_def -nooverwrite] +Dont overwrite files that already exist +[opt_def -nomtime] +Leave the file modification time as the current time instead of setting it to the value in the archive. +[opt_def -noperms] +In Unix, leave the file permissions as the current umask instead of setting them to the values in the archive. + +[opt_def -chan] +If this option is present [arg tarball] is interpreted as an open channel. +It is assumed that the channel was opened for reading, and configured for binary input. +The command will [emph not] close the channel. + +[list_end] +[para] + +[example { +% foreach {file size} [::tar::untar tarball.tar -glob *.jpg] { +puts "Extracted $file ($size bytes)" +} +}] + +[call [cmd ::tar::get] [arg tarball] [arg fileName] [opt [option -chan]]] + +Returns the contents of [arg fileName] from the [arg tarball]. + +[para][example { +% set readme [::tar::get tarball.tar doc/README] { +% puts $readme +} +}] + +[para] If the option [option -chan] is present [arg tarball] is +interpreted as an open channel. It is assumed that the channel was +opened for reading, and configured for binary input. The command will +[emph not] close the channel. + +[para] An error is thrown when [arg fileName] is not found in the tar +archive. + +[call [cmd ::tar::create] [arg tarball] [arg files] [arg args]] + +Creates a new tar file containing the [arg files]. [arg files] must be specified +as a single argument which is a proper list of filenames. + +[list_begin options] +[opt_def -dereference] +Normally [cmd create] will store links as an actual link pointing at a file that may +or may not exist in the archive. Specifying this option will cause the actual file point to + by the link to be stored instead. + +[opt_def -chan] +If this option is present [arg tarball] is interpreted as an open channel. +It is assumed that the channel was opened for writing, and configured for binary output. +The command will [emph not] close the channel. + +[list_end] +[para] + +[example { +% ::tar::create new.tar [glob -nocomplain file*] +% ::tar::contents new.tar +file1 file2 file3 +}] + +[call [cmd ::tar::add] [arg tarball] [arg files] [arg args]] + +Appends [arg files] to the end of the existing [arg tarball]. [arg files] must be specified +as a single argument which is a proper list of filenames. + +[list_begin options] +[opt_def -dereference] +Normally [cmd add] will store links as an actual link pointing at a file that may +or may not exist in the archive. Specifying this option will cause the actual file point to + by the link to be stored instead. +[opt_def -prefix string] +Normally [cmd add] will store files under exactly the name specified as +argument. Specifying a [opt -prefix] causes the [arg string] to be +prepended to every name. +[opt_def -quick] +The only sure way to find the position in the [arg tarball] where new +files can be added is to read it from start, but if [arg tarball] was +written with a "blocksize" of 1 (as this package does) then one can +alternatively find this position by seeking from the end. The +[opt -quick] option tells [cmd add] to do the latter. +[list_end] +[para] + +[call [cmd ::tar::remove] [arg tarball] [arg files]] + +Removes [arg files] from the [arg tarball]. No error will result if the file does not exist in the +tarball. Directory write permission and free disk space equivalent to at least the size of the tarball +will be needed. + +[example { +% ::tar::remove new.tar {file2 file3} +% ::tar::contents new.tar +file3 +}] + +[list_end] + +[vset CATEGORY tar] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tar.pcx b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tar.pcx new file mode 100644 index 00000000..59e008a9 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tar.pcx @@ -0,0 +1,83 @@ +# -*- tcl -*- tar.pcx +# Syntax of the commands provided by package tar. +# +# For use by TclDevKit's static syntax checker (v4.1+). +# See http://www.activestate.com/solutions/tcl/ +# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api +# for the specification of the format of the code in this file. +# + +package require pcx +pcx::register tar +pcx::tcldep 0.4 needs tcl 8.2 +pcx::tcldep 0.5 needs tcl 8.2 +pcx::tcldep 0.6 needs tcl 8.2 + +namespace eval ::tar {} + +#pcx::message FOO {... text ...} type +#pcx::scan + +pcx::check 0.4 std ::tar::add \ + {checkSimpleArgs 2 -1 { + checkFileName + {checkListValues 1 -1 checkFileName} + {checkSwitches 1 { + {-dereference checkBoolean} + } {}} + }} +pcx::check 0.6 std ::tar::add \ + {checkSimpleArgs 2 -1 { + checkFileName + {checkListValues 1 -1 checkFileName} + {checkSwitches 1 { + {-dereference checkBoolean} + {-quick checkBoolean} + {-prefix checkWord} + } {}} + }} +pcx::check 0.4 std ::tar::contents \ + {checkSimpleArgs 1 1 { + checkFileName + }} +pcx::check 0.4 std ::tar::create \ + {checkSimpleArgs 2 -1 { + checkFileName + {checkListValues 1 -1 checkFileName} + {checkSwitches 1 { + {-chan checkChannelID} + {-dereference checkBoolean} + } {}} + }} +pcx::check 0.4 std ::tar::get \ + {checkSimpleArgs 2 2 { + checkFileName + checkFileName + }} +pcx::check 0.4 std ::tar::remove \ + {checkSimpleArgs 2 2 { + checkFileName + {checkListValues 1 -1 checkFileName} + }} +pcx::check 0.4 std ::tar::stat \ + {checkSimpleArgs 1 2 { + checkFileName + checkFileName + }} +pcx::check 0.4 std ::tar::untar \ + {checkSimpleArgs 1 -1 { + checkFileName + {checkSwitches 1 { + {-chan checkChannelID} + {-dir checkFileName} + {-file checkFileName} + {-glob checkPattern} + {-nomtime checkBoolean} + {-nooverwrite checkBoolean} + {-noperms checkBoolean} + } {}} + }} + +# Initialization via pcx::init. +# Use a ::tar::init procedure for non-standard initialization. +pcx::complete diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tar.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tar.tcl new file mode 100644 index 00000000..eaff6425 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tar.tcl @@ -0,0 +1,550 @@ +# tar.tcl -- +# +# Creating, extracting, and listing posix tar archives +# +# Copyright (c) 2004 Aaron Faupell +# Copyright (c) 2013 Andreas Kupries +# (GNU tar @LongLink support). +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: tar.tcl,v 1.17 2012/09/11 17:22:24 andreas_kupries Exp $ + +package require Tcl 8.5 9 +package provide tar 0.12 + +namespace eval ::tar {} + +proc ::tar::parseOpts {acc opts} { + array set flags $acc + foreach {x y} $acc {upvar $x $x} + + set len [llength $opts] + set i 0 + while {$i < $len} { + set name [string trimleft [lindex $opts $i] -] + if {![info exists flags($name)]} { + return -errorcode {TAR INVALID OPTION} \ + -code error "unknown option \"$name\"" + } + if {$flags($name) == 1} { + set $name [lindex $opts [expr {$i + 1}]] + incr i $flags($name) + } elseif {$flags($name) > 1} { + set $name [lrange $opts [expr {$i + 1}] [expr {$i + $flags($name)}]] + incr i $flags($name) + } else { + set $name 1 + } + incr i + } +} + +proc ::tar::pad {size} { + set pad [expr {512 - ($size % 512)}] + if {$pad == 512} {return 0} + return $pad +} + +proc ::tar::seekorskip {ch off wh} { + if {[tell $ch] < 0} { + if {$wh!="current"} { + return -code error -errorcode [list TAR INVALID WHENCE $wh] \ + "WHENCE=$wh not supported on non-seekable channel $ch" + } + skip $ch $off + return + } + seek $ch $off $wh + return +} + +proc ::tar::skip {ch skipover} { + while {$skipover > 0} { + set requested $skipover + + # Limit individual skips to 64K, as a compromise between speed + # of skipping (Number of read requests), and memory usage + # (Note how skipped block is read into memory!). While the + # read data is immediately discarded it still generates memory + # allocation traffic, gets copied, etc. Trying to skip the + # block in one go without the limit may cause us to run out of + # (virtual) memory, or just induce swapping, for nothing. + + if {$requested > 65536} { + set requested 65536 + } + + set skipped [string length [read $ch $requested]] + + # Stop in short read into the end of the file. + if {!$skipped && [eof $ch]} break + + # Keep track of how much is (not) skipped yet. + incr skipover -$skipped + } + return +} + +proc ::tar::readHeader {data} { + binary scan $data a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155 \ + name mode uid gid size mtime cksum type \ + linkname magic version uname gname devmajor devminor prefix + + foreach x {name type linkname} { + set $x [string trim [set $x] "\x00"] + } + foreach x {uid gid size mtime cksum} { + set $x [format %d 0[string trim [set $x] " \x00"]] + } + set mode [string trim $mode " \x00"] + + if {$magic == "ustar "} { + # gnu tar + # not fully supported + foreach x {uname gname prefix} { + set $x [string trim [set $x] "\x00"] + } + foreach x {devmajor devminor} { + set $x [format %d 0[string trim [set $x] " \x00"]] + } + } elseif {$magic == "ustar\x00"} { + # posix tar + foreach x {uname gname prefix} { + set $x [string trim [set $x] "\x00"] + } + foreach x {devmajor devminor} { + set $x [format %d 0[string trim [set $x] " \x00"]] + } + } else { + # old style tar + foreach x {uname gname devmajor devminor prefix} { set $x {} } + if {$type == ""} { + if {[string match */ $name]} { + set type 5 + } else { + set type 0 + } + } + } + + return [list name $name mode $mode uid $uid gid $gid size $size mtime $mtime \ + cksum $cksum type $type linkname $linkname magic $magic \ + version $version uname $uname gname $gname devmajor $devmajor \ + devminor $devminor prefix $prefix] +} + +proc ::tar::contents {file args} { + set chan 0 + parseOpts {chan 0} $args + if {$chan} { + set fh $file + } else { + set fh [::open $file] + fconfigure $fh -encoding binary -translation lf -eofchar {} + } + set ret {} + while {![eof $fh]} { + array set header [readHeader [read $fh 512]] + HandleLongLink $fh header + if {$header(name) == ""} break + if {$header(prefix) != ""} {append header(prefix) /} + lappend ret $header(prefix)$header(name) + seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current + } + if {!$chan} { + close $fh + } + return $ret +} + +proc ::tar::stat {tar {file {}} args} { + set chan 0 + parseOpts {chan 0} $args + if {$chan} { + set fh $tar + } else { + set fh [::open $tar] + fconfigure $fh -encoding binary -translation lf -eofchar {} + } + set ret {} + while {![eof $fh]} { + array set header [readHeader [read $fh 512]] + HandleLongLink $fh header + if {$header(name) == ""} break + if {$header(prefix) != ""} {append header(prefix) /} + seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current + if {$file != "" && "$header(prefix)$header(name)" != $file} {continue} + set header(type) [string map {0 file 5 directory 3 characterSpecial 4 blockSpecial 6 fifo 2 link} $header(type)] + set header(mode) [string range $header(mode) 2 end] + lappend ret $header(prefix)$header(name) [list mode $header(mode) uid $header(uid) gid $header(gid) \ + size $header(size) mtime $header(mtime) type $header(type) linkname $header(linkname) \ + uname $header(uname) gname $header(gname) devmajor $header(devmajor) devminor $header(devminor)] + } + if {!$chan} { + close $fh + } + return $ret +} + +proc ::tar::get {tar file args} { + set chan 0 + parseOpts {chan 0} $args + if {$chan} { + set fh $tar + } else { + set fh [::open $tar] + fconfigure $fh -encoding binary -translation lf -eofchar {} + } + while {![eof $fh]} { + set data [read $fh 512] + array set header [readHeader $data] + HandleLongLink $fh header + if {$header(name) eq ""} break + if {$header(prefix) ne ""} {append header(prefix) /} + set name [string trimleft $header(prefix)$header(name) /] + if {$name eq $file} { + set file [read $fh $header(size)] + if {!$chan} { + close $fh + } + return $file + } + seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current + } + if {!$chan} { + close $fh + } + return -code error -errorcode {TAR MISSING FILE} \ + "Tar \"$tar\": File \"$file\" not found" +} + +proc ::tar::untar {tar args} { + set nooverwrite 0 + set data 0 + set nomtime 0 + set noperms 0 + set chan 0 + parseOpts {dir 1 file 1 glob 1 nooverwrite 0 nomtime 0 noperms 0 chan 0} $args + if {![info exists dir]} {set dir [pwd]} + set pattern * + if {[info exists file]} { + set pattern [string map {* \\* ? \\? \\ \\\\ \[ \\\[ \] \\\]} $file] + } elseif {[info exists glob]} { + set pattern $glob + } + + set ret {} + if {$chan} { + set fh $tar + } else { + set fh [::open $tar] + fconfigure $fh -encoding binary -translation lf -eofchar {} + } + while {![eof $fh]} { + array set header [readHeader [read $fh 512]] + HandleLongLink $fh header + if {$header(name) == ""} break + if {$header(prefix) != ""} {append header(prefix) /} + set name [string trimleft $header(prefix)$header(name) /] + if {![string match $pattern $name] || ($nooverwrite && [file exists $name])} { + seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current + continue + } + + set name [file join $dir $name] + if {![file isdirectory [file dirname $name]]} { + file mkdir [file dirname $name] + lappend ret [file dirname $name] {} + } + if {[string match {[0346]} $header(type)]} { + if {[catch {::open $name w+} new]} { + # sometimes if we dont have write permission we can still delete + catch {file delete -force $name} + set new [::open $name w+] + } + fconfigure $new -encoding binary -translation lf -eofchar {} + fcopy $fh $new -size $header(size) + close $new + lappend ret $name $header(size) + } elseif {$header(type) == 5} { + file mkdir $name + lappend ret $name {} + } elseif {[string match {[12]} $header(type)] && $::tcl_platform(platform) == "unix"} { + catch {file delete $name} + if {![catch {file link [string map {1 -hard 2 -symbolic} $header(type)] $name $header(linkname)}]} { + lappend ret $name {} + } + } + seekorskip $fh [pad $header(size)] current + if {![file exists $name]} continue + + if {$::tcl_platform(platform) == "unix"} { + if {!$noperms} { + catch {file attributes $name -permissions 0o[string range $header(mode) 2 end]} + } + catch {file attributes $name -owner $header(uid) -group $header(gid)} + catch {file attributes $name -owner $header(uname) -group $header(gname)} + } + if {!$nomtime} { + file mtime $name $header(mtime) + } + } + if {!$chan} { + close $fh + } + return $ret +} + +## + # ::tar::statFile + # + # Returns stat info about a filesystem object, in the form of an info + # dictionary like that returned by ::tar::readHeader. + # + # The mode, uid, gid, mtime, and type entries are always present. + # The size and linkname entries are present if relevant for this type + # of object. The uname and gname entries are present if the OS supports + # them. No devmajor or devminor entry is present. + ## + +proc ::tar::statFile {name followlinks} { + if {$followlinks} { + file stat $name stat + } else { + file lstat $name stat + } + + set ret {} + + if {$::tcl_platform(platform) == "unix"} { + # Tcl 9 returns the permission as 0o octal number. Since this + # is written to the tar file and the file format expects "00" + # we have to rewrite. + lappend ret mode 1[string map {o 0} [file attributes $name -permissions]] + lappend ret uname [file attributes $name -owner] + lappend ret gname [file attributes $name -group] + if {$stat(type) == "link"} { + lappend ret linkname [file link $name] + } + } else { + lappend ret mode [lindex {100644 100755} [expr {$stat(type) == "directory"}]] + } + + lappend ret uid $stat(uid) gid $stat(gid) mtime $stat(mtime) \ + type $stat(type) + + if {$stat(type) == "file"} {lappend ret size $stat(size)} + + return $ret +} + +## + # ::tar::formatHeader + # + # Opposite operation to ::tar::readHeader; takes a file name and info + # dictionary as arguments, returns a corresponding (POSIX-tar) header. + # + # The following dictionary entries must be present: + # mode + # type + # + # The following dictionary entries are used if present, otherwise + # the indicated default is used: + # uid 0 + # gid 0 + # size 0 + # mtime [clock seconds] + # linkname {} + # uname {} + # gname {} + # + # All other dictionary entries, including devmajor and devminor, are + # presently ignored. + ## + +proc ::tar::formatHeader {name info} { + array set A { + linkname "" + uname "" + gname "" + size 0 + gid 0 + uid 0 + } + set A(mtime) [clock seconds] + array set A $info + array set A {devmajor "" devminor ""} + + set type [string map {file 0 directory 5 characterSpecial 3 \ + blockSpecial 4 fifo 6 link 2 socket A} $A(type)] + + set osize [format %o $A(size)] + set ogid [format %o $A(gid)] + set ouid [format %o $A(uid)] + set omtime [format %o $A(mtime)] + + set name [string trimleft $name /] + if {[string length $name] > 255} { + return -code error -errorcode {TAR BAD PATH LENGTH} \ + "path name over 255 chars" + } elseif {[string length $name] > 100} { + set common [string range $name end-99 154] + if {[set splitpoint [string first / $common]] == -1} { + return -code error -errorcode {TAR BAD PATH UNSPLITTABLE} \ + "path name cannot be split into prefix and name" + } + set prefix [string range $name 0 end-100][string range $common 0 $splitpoint-1] + set name [string range $common $splitpoint+1 end][string range $name 155 end] + } else { + set prefix "" + } + + set header [binary format a100A8A8A8A12A12A8a1a100A6a2a32a32a8a8a155a12 \ + $name $A(mode)\x00 $ouid\x00 $ogid\x00\ + $osize\x00 $omtime\x00 {} $type \ + $A(linkname) ustar\x00 00 $A(uname) $A(gname)\ + $A(devmajor) $A(devminor) $prefix {}] + + binary scan $header c* tmp + set cksum 0 + foreach x $tmp {incr cksum $x} + + return [string replace $header 148 155 [binary format A8 [format %o $cksum]\x00]] +} + + +proc ::tar::recurseDirs {files followlinks} { + foreach x $files { + if {[file isdirectory $x] && ([file type $x] != "link" || $followlinks)} { + if {[set more [glob -dir $x -nocomplain *]] != ""} { + eval lappend files [recurseDirs $more $followlinks] + } else { + lappend files $x + } + } + } + return $files +} + +proc ::tar::writefile {in out followlinks name} { + puts -nonewline $out [formatHeader $name [statFile $in $followlinks]] + set size 0 + if {[file type $in] == "file" || ($followlinks && [file type $in] == "link")} { + set in [::open $in] + fconfigure $in -encoding binary -translation lf -eofchar {} + set size [fcopy $in $out] + close $in + } + puts -nonewline $out [string repeat \x00 [pad $size]] +} + +proc ::tar::create {tar files args} { + set dereference 0 + set chan 0 + parseOpts {dereference 0 chan 0} $args + + if {$chan} { + set fh $tar + } else { + set fh [::open $tar w+] + fconfigure $fh -encoding binary -translation lf -eofchar {} + } + foreach x [recurseDirs $files $dereference] { + writefile $x $fh $dereference $x + } + puts -nonewline $fh [string repeat \x00 1024] + + if {!$chan} { + close $fh + } + return $tar +} + +proc ::tar::add {tar files args} { + set dereference 0 + set prefix "" + set quick 0 + parseOpts {dereference 0 prefix 1 quick 0} $args + + set fh [::open $tar r+] + fconfigure $fh -encoding binary -translation lf -eofchar {} + + if {$quick} then { + seek $fh -1024 end + } else { + set data [read $fh 512] + while {[regexp {[^\0]} $data]} { + array set header [readHeader $data] + seek $fh [expr {$header(size) + [pad $header(size)]}] current + set data [read $fh 512] + } + seek $fh -512 current + } + + foreach x [recurseDirs $files $dereference] { + writefile $x $fh $dereference $prefix$x + } + puts -nonewline $fh [string repeat \x00 1024] + + close $fh + return $tar +} + +proc ::tar::remove {tar files} { + set n 0 + while {[file exists $tar$n.tmp]} {incr n} + set tfh [::open $tar$n.tmp w] + set fh [::open $tar r] + + fconfigure $fh -encoding binary -translation lf -eofchar {} + fconfigure $tfh -encoding binary -translation lf -eofchar {} + + while {![eof $fh]} { + array set header [readHeader [read $fh 512]] + if {$header(name) == ""} { + puts -nonewline $tfh [string repeat \x00 1024] + break + } + if {$header(prefix) != ""} {append header(prefix) /} + set name $header(prefix)$header(name) + set len [expr {$header(size) + [pad $header(size)]}] + if {[lsearch $files $name] > -1} { + seek $fh $len current + } else { + seek $fh -512 current + fcopy $fh $tfh -size [expr {$len + 512}] + } + } + + close $fh + close $tfh + + file rename -force $tar$n.tmp $tar +} + +proc ::tar::HandleLongLink {fh hv} { + upvar 1 $hv header thelongname thelongname + + # @LongName Part I. + if {$header(type) == "L"} { + # Size == Length of name. Read it, and pad to full 512 + # size. After that is a regular header for the actual + # file, where we have to insert the name. This is handled + # by the next iteration and the part II below. + set thelongname [string trimright [read $fh $header(size)] \000] + seekorskip $fh [pad $header(size)] current + return -code continue + } + # Not supported yet: type 'K' for LongLink (long symbolic links). + + # @LongName, part II, get data from previous entry, if defined. + if {[info exists thelongname]} { + set header(name) $thelongname + # Prevent leakage to further entries. + unset thelongname + } + + return +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tar.test b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tar.test new file mode 100644 index 00000000..bc31128b --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tar.test @@ -0,0 +1,139 @@ +# -*- tcl -*- +# These tests are in the public domain +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file normalize [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.5 ; # Virt channel support! +testsNeedTcltest 1.0 + +# Check if we have TclOO available. +tcltest::testConstraint tcloo [expr {![catch {package require TclOO}]}] + +support { + if {[tcltest::testConstraint tcloo]} { + use virtchannel_base/memchan.tcl tcl::chan::memchan + } + useLocalFile tests/support.tcl +} +testing { + useLocal tar.tcl tar +} + +# ------------------------------------------------------------------------- + +test tar-stream {stream} -constraints tcloo -setup { + setup1 +} -body { + string length [read $chan1] +} -cleanup { + cleanup1 +} -result 128000 + +test tar-pad {pad} -body { + tar::pad 230 +} -result {282} + +test tar-skip {skip} -constraints tcloo -setup { + setup1 +} -body { + tar::skip $chan1 10 + lappend res [read $chan1 10] + tar::skip $chan1 72313 + lappend res [read $chan1 10] +} -cleanup { + cleanup1 +} -result {{6 7 8 9 10} {07 13908 1}} + +test tar-seekorskip-backwards {seekorskip} -constraints tcl8.6plus -setup setup1 -body { + # The zlib push stuff is Tcl 8.6+. Properly restrict the test. + zlib push gzip $chan1 + catch {tar::seekorskip $chan1 -10 start} cres + lappend res $cres + catch {tar::seekorskip $chan1 10 start} cres + lappend res $cres + catch {tar::seekorskip $chan1 -10 end} cres + lappend res $cres + catch {tar::seekorskip $chan1 10 end} cres + lappend res $cres + lappend res [read $chan1 10] +} -cleanup cleanup1 -match glob \ + -result [list \ + {WHENCE=start not supported*} \ + {WHENCE=start not supported*} \ + {WHENCE=end not supported*} \ + {WHENCE=end not supported*} \ + {1 2 3 4 5 } \ + ] + +test tar-header {header} -body { + set file1 [dict get $filesys Dir1 File1] + dict set file1 path /Dir1/File1 + set header [header_posix $file1] + set parsed [string trim [tar::readHeader $header]] + set golden "name /Dir1/File1 mode 755 uid 13103 gid 18103 size 100 mtime 5706756101 cksum 3676 type 0 linkname {} magic ustar\0 version 00 uname {} gname {} devmajor 0 devminor 0 prefix {}" + set len [string length $parsed] + foreach {key value} $golden { + if {[set value1 [dict get $parsed $key]] ne $value } { + lappend res [list $key $value $value1] + } + } +} -result {} + +test tar-add {add} -constraints tcloo -setup { + setup1 +} -body { + tar::create $chan1 [list $tmpdir/one/a $tmpdir/one/two/a $tmpdir/one/three/a] -chan + seek $chan1 0 + lappend res {*}[tar::contents $chan1 -chan] + seek $chan1 0 + lappend res [string trim [tar::get $chan1 $tmpdir/one/two/a -chan]] +} -cleanup { + cleanup1 +} -result {tartest/one/a tartest/one/two/a tartest/one/three/a hello2} + + +test tar-bug-2840180 {Ticket 2840180} -setup { + setup2 +} -body { + tar::create $chan1 [list $tmpdir/[large-path]/a] -chan + seek $chan1 0 + + # What the package sees. + lappend res {*}[tar::contents $chan1 -chan] + close $chan1 + + # What a regular tar package sees. + lappend res [exec 2> $tmpfile.err tar tvf $tmpfile] + join $res \n +} -cleanup { + cleanup2 +} -match glob -result [join [list \ + tartest/[large-path]/a \ + "* tartest/[large-path]/a" \ + ] \n] + +# ------------------------------------------------------------------------- + +test tar-tkt-9f4c0e3e95-1.0 {Ticket 9f4c0e3e95, A} -setup { + set tarfile [setup-tkt-9f4c0e3e95] +} -body { + string trim [tar::get $tarfile 02] +} -cleanup { + cleanup-tkt-9f4c0e3e95 + unset tarfile +} -result {zero-two} + +test tar-tkt-9f4c0e3e95-1.1 {Ticket 9f4c0e3e95, B, } -setup { + set tarfile [setup-tkt-9f4c0e3e95] +} -body { + tar::get $tarfile 0b10 +} -cleanup { + cleanup-tkt-9f4c0e3e95 + unset tarfile +} -returnCodes error -result {Tar "tartest/t.tar": File "0b10" not found} + +# ------------------------------------------------------------------------- +testsuiteCleanup diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tests/support.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tests/support.tcl new file mode 100644 index 00000000..9e8af1d3 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/tar/tests/support.tcl @@ -0,0 +1,149 @@ + +proc stream {{size 128000}} { + set chan [tcl::chan::memchan] + set line {} + while 1 { + incr i + set istring $i + set ilen [string length $istring] + if {$line ne {}} { + append line { } + incr size -1 + } + append line $istring + incr size -$ilen + if {$size < 1} { + set line [string range $line 0 end-[expr {abs(1-$size)}]] + puts $chan $line + break + } + + if {$i % 10 == 0} { + puts $chan $line + incr size -1 ;# for the [puts] newline + set line {} + } + } + + seek $chan 0 + return $chan +} + +proc header_posix {tarball} { + dict with tarball {} + tar::formatHeader $path \ + [dict create \ + mode $mode \ + type $type \ + uid $uid \ + gid $gid \ + size $size \ + mtime $mtime] +} + +proc setup1 {} { + variable chan1 + variable res {} + variable tmpdir tartest + + tcltest::makeDirectory $tmpdir + + foreach directory { + one + one/two + one/three + } { + tcltest::makeDirectory $tmpdir/$directory + set chan [open $tmpdir/$directory/a w] + puts $chan hello[incr i] + close $chan + } + set chan1 [stream] +} + +proc large-path {} { + return aaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbtcllib/modules/tar +} + +proc setup2 {} { + variable chan1 + variable res {} + variable tmpdir tartest + variable tmpfile tarX + + tcltest::makeDirectory $tmpdir + tcltest::makeFile {} $tmpfile + + foreach directory [list [large-path]] { + tcltest::makeDirectory $tmpdir/$directory + set chan [open $tmpdir/$directory/a w] + puts $chan hello[incr i] + close $chan + } + set chan1 [open $tmpfile w+] +} + +proc cleanup1 {} { + variable chan1 + close $chan1 + tcltest::removeDirectory tartest + return +} + +proc cleanup2 {} { + variable chan1 + variable tmpdir + variable tmpfile + catch { close $chan1 } + tcltest::removeDirectory $tmpdir + tcltest::removeFile $tmpfile + tcltest::removeFile $tmpfile.err + return +} + +variable filesys { + Dir1 { + File1 { + type 0 + mode 755 + uid 13103 + gid 18103 + size 100 + mtime 5706756101 + } + } + + Dir2 { + File1 { + type 0 + mode 644 + uid 15103 + gid 19103 + size 100 + mtime 5706776103 + } + } +} + +proc setup-tkt-9f4c0e3e95 {} { + variable tmpdir tartest + + tcltest::makeDirectory $tmpdir + tcltest::makeFile {zero-two} $tmpdir/02 + tcltest::makeFile {number two} $tmpdir/2 + + set here [pwd] + cd $tmpdir + tar::create t.tar {2 02} + cd $here + + return $tmpdir/t.tar +} + +proc cleanup-tkt-9f4c0e3e95 {} { + variable tmpdir + tcltest::removeFile $tmpdir/2 + tcltest::removeFile $tmpdir/02 + tcltest::removeDirectory $tmpdir + return +} diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/code.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/code.tcl new file mode 100644 index 00000000..95792252 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/code.tcl @@ -0,0 +1,56 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI +## Generic commands to define commands for code sequences. + +# ### ### ### ######### ######### ######### +## Requirements + +namespace eval ::term::ansi::code {} + +# ### ### ### ######### ######### ######### +## API. Escape clauses, plain and bracket +## Used by 'define'd commands. + +proc ::term::ansi::code::esc {str} {return \033$str} +proc ::term::ansi::code::escb {str} {esc \[$str} + +# ### ### ### ######### ######### ######### +## API. Define command for named control code, or constant. +## (Simple definitions without arguments) + +proc ::term::ansi::code::define {name escape code} { + proc [Qualified $name] {} [list ::term::ansi::code::$escape $code] +} + +proc ::term::ansi::code::const {name code} { + proc [Qualified $name] {} [list return $code] +} + +# ### ### ### ######### ######### ######### +## Internal helper to construct fully-qualified names. + +proc ::term::ansi::code::Qualified {name} { + if {![string match ::* $name]} { + # Get the caller's namespace; append :: if it is not the + # global namespace, for separation from the actual name. + set ns [uplevel 2 [list namespace current]] + if {$ns ne "::"} {append ns ::} + set name $ns$name + } + return $name +} + +# ### ### ### ######### ######### ######### + +namespace eval ::term::ansi::code { + namespace export esc escb define const +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::code 0.3 + +## +# ### ### ### ######### ######### ######### diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/code/attr.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/code/attr.tcl new file mode 100644 index 00000000..20e622e7 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/code/attr.tcl @@ -0,0 +1,108 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI - Attribute codes + +# ### ### ### ######### ######### ######### +## Requirements + +package require term::ansi::code ; # Constants + +namespace eval ::term::ansi::code::attr {} + +# ### ### ### ######### ######### ######### +## API. Symbolic names. + +proc ::term::ansi::code::attr::names {} { + variable attr + return $attr +} + +proc ::term::ansi::code::attr::import {{ns attr} args} { + if {![llength $args]} {set args *} + set args ::term::ansi::code::attr::[join $args " ::term::ansi::code::attr::"] + uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] + return +} + +# ### ### ### ######### ######### ######### +## Internal - Setup + +proc ::term::ansi::code::attr::DEF {name value} { + variable attr + const $name $value + lappend attr $name + namespace export $name + return +} + +proc ::term::ansi::code::attr::INIT {} { + # ### ### ### ######### ######### ######### + ## + + # Colors. Foreground <=> Text + DEF fgblack 30 ; # Black + DEF fgred 31 ; # Red + DEF fggreen 32 ; # Green + DEF fgyellow 33 ; # Yellow + DEF fgblue 34 ; # Blue + DEF fgmagenta 35 ; # Magenta + DEF fgcyan 36 ; # Cyan + DEF fgwhite 37 ; # White + DEF fgdefault 39 ; # Default (Black) + + # Colors. Background. + DEF bgblack 40 ; # Black + DEF bgred 41 ; # Red + DEF bggreen 42 ; # Green + DEF bgyellow 43 ; # Yellow + DEF bgblue 44 ; # Blue + DEF bgmagenta 45 ; # Magenta + DEF bgcyan 46 ; # Cyan + DEF bgwhite 47 ; # White + DEF bgdefault 49 ; # Default (Transparent) + + # Non-color attributes. Activation. + DEF bold 1 ; # Bold + DEF dim 2 ; # Dim + DEF italic 3 ; # Italics + DEF underline 4 ; # Underscore + DEF blink 5 ; # Blink + DEF revers 7 ; # Reverse + DEF hidden 8 ; # Hidden + DEF strike 9 ; # StrikeThrough + + # Non-color attributes. Deactivation. + DEF nobold 22 ; # Bold + DEF nodim __ ; # Dim + DEF noitalic 23 ; # Italics + DEF nounderline 24 ; # Underscore + DEF noblink 25 ; # Blink + DEF norevers 27 ; # Reverse + DEF nohidden 28 ; # Hidden + DEF nostrike 29 ; # StrikeThrough + + # Remainder + DEF reset 0 ; # Reset + + ## + # ### ### ### ######### ######### ######### + return +} + +# ### ### ### ######### ######### ######### +## Data structures. + +namespace eval ::term::ansi::code::attr { + namespace import ::term::ansi::code::const + variable attr {} +} + +::term::ansi::code::attr::INIT + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::code::attr 0.2 + +## +# ### ### ### ######### ######### ######### diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/code/ctrl.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/code/ctrl.tcl new file mode 100644 index 00000000..f0f8ca56 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/code/ctrl.tcl @@ -0,0 +1,272 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI - Control codes + +## References +# [0] Google: ansi terminal control +# [1] http://vt100.net/docs/vt100-ug/chapter3.html +# [2] http://www.termsys.demon.co.uk/vtansi.htm +# [3] http://rrbrandt.dyndns.org:60000/docs/tut/redes/ansi.php +# [4] http://www.dee.ufcg.edu.br/~rrbrandt/tools/ansi.html +# [5] http://www.ecma-international.org/publications/standards/Ecma-048.htm + +# ### ### ### ######### ######### ######### +## Requirements + +package require term::ansi::code +package require term::ansi::code::attr + +namespace eval ::term::ansi::code::ctrl {} + +# ### ### ### ######### ######### ######### +## API. Symbolic names. + +proc ::term::ansi::code::ctrl::names {} { + variable ctrl + return $ctrl +} + +proc ::term::ansi::code::ctrl::import {{ns ctrl} args} { + if {![llength $args]} {set args *} + set args ::term::ansi::code::ctrl::[join $args " ::term::ansi::code::ctrl::"] + uplevel 1 [list namespace eval $ns [linsert $args 0 namespace import]] + return +} + +# ### ### ### ######### ######### ######### + +## TODO = symbolic key codes for skd. + +# ### ### ### ######### ######### ######### +## Internal - Setup + +proc ::term::ansi::code::ctrl::DEF {name esc value} { + variable ctrl + define $name $esc $value + lappend ctrl $name + namespace export $name + return +} + +proc ::term::ansi::code::ctrl::DEFC {name arguments script} { + variable ctrl + proc $name $arguments $script + lappend ctrl $name + namespace export $name + return +} + +proc ::term::ansi::code::ctrl::INIT {} { + # ### ### ### ######### ######### ######### + ## + + # Erasing + + DEF eeol escb K ; # Erase (to) End Of Line + DEF esol escb 1K ; # Erase (to) Start Of Line + DEF el escb 2K ; # Erase (current) Line + DEF ed escb J ; # Erase Down (to bottom) + DEF eu escb 1J ; # Erase Up (to top) + DEF es escb 2J ; # Erase Screen + + # Scrolling + + DEF sd esc D ; # Scroll Down + DEF su esc M ; # Scroll Up + + # Cursor Handling + + DEF ch escb H ; # Cursor Home + DEF sc escb s ; # Save Cursor + DEF rc escb u ; # Restore Cursor (Unsave) + DEF sca esc 7 ; # Save Cursor + Attributes + DEF rca esc 8 ; # Restore Cursor + Attributes + + # Tabbing + + DEF st esc H ; # Set Tab (@ current position) + DEF ct escb g ; # Clear Tab (@ current position) + DEF cat escb 3g ; # Clear All Tabs + + # Device Introspection + + DEF qdc escb c ; # Query Device Code + DEF qds escb 5n ; # Query Device Status + DEF qcp escb 6n ; # Query Cursor Position + DEF rd esc c ; # Reset Device + + # Linewrap on/off + + DEF elw escb 7h ; # Enable Line Wrap + DEF dlw escb 7l ; # Disable Line Wrap + + # Graphics Mode (aka use alternate font on/off) + + DEF eg esc F ; # Enter Graphics Mode + DEF lg esc G ; # Exit Graphics Mode + + ## + # ### ### ### ######### ######### ######### + + # ### ### ### ######### ######### ######### + ## Complex, parameterized codes + + # Select Character Set + # Choose which char set is used for default and + # alternate font. This does not change whether + # default or alternate font are used + + DEFC scs0 {tag} {esc ($tag} ; # Set default character set + DEFC scs1 {tag} {esc )$tag} ; # Set alternate character set + + # tags in A : United Kingdom Set + # B : ASCII Set + # 0 : Special Graphics + # 1 : Alternate Character ROM Standard Character Set + # 2 : Alternate Character ROM Special Graphics + + # Set Display Attributes + + DEFC sda {args} {escb [join $args \;]m} + + # Force Cursor Position (aka Go To) + + DEFC fcp {r c} {escb ${r}\;${c}f} + + # Cursor Up, Down, Forward, Backward + + DEFC cu {{n 1}} {escb [expr {$n == 1 ? "A" : "${n}A"}]} + DEFC cd {{n 1}} {escb [expr {$n == 1 ? "B" : "${n}B"}]} + DEFC cf {{n 1}} {escb [expr {$n == 1 ? "C" : "${n}C"}]} + DEFC cb {{n 1}} {escb [expr {$n == 1 ? "D" : "${n}D"}]} + + # Scroll Screen (entire display, or between rows start end, inclusive). + + DEFC ss {args} { + if {[llength $args] == 0} {return [escb r]} + if {[llength $args] == 2} {foreach {s e} $args break ; return [escb ${s};${e}r]} + return -code error "wrong\#args" + } + + # Set Key Definition + + DEFC skd {code str} {escb $code\;\"$str\"p} + + # Terminal title + + DEFC title {str} {esc \]0\;$str\007} + + # Switch to and from character/box graphics. + + DEFC gron {} {esc (0} + DEFC groff {} {esc (B} + + # Character graphics, box symbols + # - 4 corners, 4 t-junctions, + # one 4-way junction, 2 lines + + DEFC tlc {} {return [gron]l[groff]} ; # Top Left Corner + DEFC trc {} {return [gron]k[groff]} ; # Top Right Corner + DEFC brc {} {return [gron]j[groff]} ; # Bottom Right Corner + DEFC blc {} {return [gron]m[groff]} ; # Bottom Left Corner + + DEFC ltj {} {return [gron]t[groff]} ; # Left T Junction + DEFC ttj {} {return [gron]w[groff]} ; # Top T Junction + DEFC rtj {} {return [gron]u[groff]} ; # Right T Junction + DEFC btj {} {return [gron]v[groff]} ; # Bottom T Junction + + DEFC fwj {} {return [gron]n[groff]} ; # Four-Way Junction + + DEFC hl {} {return [gron]q[groff]} ; # Horizontal Line + DEFC vl {} {return [gron]x[groff]} ; # Vertical Line + + # Optimize character graphics. The generator commands above create + # way to many superfluous commands shifting into and out of the + # graphics mode. The command below removes all shifts which are + # not needed. To this end it also knows which characters will look + # the same in both modes, to handle strings created outside this + # package. + + DEFC groptim {string} { + variable grforw + variable grback + set offon [groff][gron] + set onoff [gron][groff] + while {![string equal $string [set new [string map \ + [list $offon {} $onoff {}] [string map \ + $grback [string map \ + $grforw $string]]]]]} { + set string $new + } + return $string + } + + ## + # ### ### ### ######### ######### ######### + + # ### ### ### ######### ######### ######### + ## Higher level operations + + # Clear screen <=> CursorHome + EraseDown + # Init (Fonts): Default ASCII, Alternate Graphics + # Show a block of text at a specific location. + + DEFC clear {} {return [ch][ed]} + DEFC init {} {return [scs0 B][scs1 0]} + + DEFC showat {r c text} { + if {![string length $text]} {return {}} + return [fcp $r $c][sca][join \ + [split $text \n] \ + [rca][cd][sca]][rca][cd] + } + + ## + # ### ### ### ######### ######### ######### + + # ### ### ### ######### ######### ######### + ## Attribute control (single attributes) + + foreach a [::term::ansi::code::attr::names] { + DEF sda_$a escb [::term::ansi::code::attr::$a]m + } + + ## + # ### ### ### ######### ######### ######### + return +} + +# ### ### ### ######### ######### ######### +## Data structures. + +namespace eval ::term::ansi::code::ctrl { + namespace import ::term::ansi::code::define + namespace import ::term::ansi::code::esc + namespace import ::term::ansi::code::escb + + 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 _ +} + +::term::ansi::code::ctrl::INIT + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::code::ctrl 0.4 + +## +# ### ### ### ######### ######### ######### diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/code/macros.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/code/macros.tcl new file mode 100644 index 00000000..efcbd31e --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/code/macros.tcl @@ -0,0 +1,93 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI - Higher level macros + +# ### ### ### ######### ######### ######### +## Requirements + +package require textutil::repeat +package require textutil::tabify +package require term::ansi::code::ctrl + +namespace eval ::term::ansi::code::macros {} + +# ### ### ### ######### ######### ######### +## API. Symbolic names. + +proc ::term::ansi::code::macros::import {{ns macros} args} { + if {![llength $args]} {set args *} + set args ::term::ansi::code::macros::[join $args " ::term::ansi::code::macros::"] + uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] + return +} + +# ### ### ### ######### ######### ######### +## Higher level operations + +# Format a menu / framed block of text + +proc ::term::ansi::code::macros::menu {menu} { + # Menu = dict (label => char) + array set _ {} + set shift 0 + foreach {label c} $menu { + if {[string first $c $label] < 0} { + set shift 1 + break + } + } + set max 0 + foreach {label c} $menu { + set pos [string first $c $label] + if {$shift || ($pos < 0)} { + set xlabel "$c $label" + set pos 0 + } else { + set xlabel $label + } + set len [string length $xlabel] + if {$len > $max} {set max $len} + set _($label) " [string replace $xlabel $pos $pos \ + [cd::sda_fgred][cd::sda_bold][string index $xlabel $pos][cd::sda_reset]]" + } + + append ms [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]\n + foreach {l c} $menu {append ms $_($l)\n} + append ms [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc] + + return [cd::groptim $ms] +} + +proc ::term::ansi::code::macros::frame {string} { + set lines [split [textutil::tabify::untabify2 $string] \n] + set max 0 + foreach l $lines { + if {[set len [string length $l]] > $max} {set max $len} + } + append fs [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]\n + foreach l $lines { + append fs [cd::vl]${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]][cd::vl]\n + } + append fs [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc] + return [cd::groptim $fs] +} + +## +# ### ### ### ######### ######### ######### + +# ### ### ### ######### ######### ######### +## Data structures. + +namespace eval ::term::ansi::code::macros { + term::ansi::code::ctrl::import cd + + namespace export menu frame +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::code::macros 0.2 + +## +# ### ### ### ######### ######### ######### diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/ctrlunix.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/ctrlunix.tcl new file mode 100644 index 00000000..263ec9d4 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/ctrlunix.tcl @@ -0,0 +1,91 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI - Control operations +## (Unix specific implementation). + +## This was originally taken from page 11820 (Pure Tcl Console Editor) +## of the Tcler's Wiki, however page 14693 (Reading a single character +## ...) is the same in a more self-contained manner. + +# ### ### ### ######### ######### ######### +## Requirements + +namespace eval ::term::ansi::ctrl::unix {} + +# ### ### ### ######### ######### ######### +## Make command easily available + +proc ::term::ansi::ctrl::unix::import {{ns ctrl} args} { + if {![llength $args]} {set args *} + set args ::term::ansi::ctrl::unix::[join $args " ::term::ansi::ctrl::unix::"] + uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] + return +} + +# ### ### ### ######### ######### ######### +## API + +# We use the <@stdin because stty works out what terminal to work with +# using standard input on some platforms. On others it prefers +# /dev/tty instead, but putting in the redirection makes the code more +# portable + +proc ::term::ansi::ctrl::unix::raw {} { + variable stty + exec $stty raw -echo <@stdin + return +} + +proc ::term::ansi::ctrl::unix::cooked {} { + variable stty + exec $stty -raw echo <@stdin + return +} + +proc ::term::ansi::ctrl::unix::columns {} { + variable tput + return [exec $tput cols <@stdin] +} + +proc ::term::ansi::ctrl::unix::rows {} { + variable tput + return [exec $tput lines <@stdin] +} + +# ### ### ### ######### ######### ######### +## Package setup + +proc ::term::ansi::ctrl::unix::INIT {} { + variable tput [auto_execok tput] + variable stty [auto_execok stty] + + if {($stty eq "/usr/ucb/stty") && + ($::tcl_platform(os) eq "SunOS")} { + set stty /usr/bin/stty + } + + if {($tput eq "") || ($stty eq "")} { + return -code error \ + "The external requirements for the \ + use of this package (tput, stty in \ + \$PATH) are not met." + } + return +} + +namespace eval ::term::ansi::ctrl::unix { + variable tput {} + variable stty {} + + namespace export columns rows raw cooked +} + +::term::ansi::ctrl::unix::INIT + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::ctrl::unix 0.1.2 + +## +# ### ### ### ######### ######### ######### diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/send.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/send.tcl new file mode 100644 index 00000000..895a30c2 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ansi/send.tcl @@ -0,0 +1,92 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI - Control codes + +# ### ### ### ######### ######### ######### +## Requirements + +package require Tcl 8.5 9 +package require term::send +package require term::ansi::code::ctrl + +namespace eval ::term::ansi::send {} + +# ### ### ### ######### ######### ######### +## Make command easily available + +proc ::term::ansi::send::import {{ns send} args} { + if {![llength $args]} {set args *} + set args ::term::ansi::send::[join $args " ::term::ansi::send::"] + uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] + return +} + +# ### ### ### ######### ######### ######### +## Internal - Setup. + +proc ::term::ansi::send::ChName {n} { + if {![string match *-* $n]} { + return ${n}ch + } + set nl [split $n -] + set stem [lindex $nl 0] + set sfx [join [lrange $nl 1 end] -] + return ${stem}ch-$sfx +} + +proc ::term::ansi::send::Args {n -> arv achv avv} { + upvar 1 $arv a $achv ach $avv av + set code ::term::ansi::code::ctrl::$n + set a [info args $code] + set av [expr { + [llength $a] + ? " \$[join $a { $}]" + : $a + }] + foreach a1 $a[set a {}] { + if {[info default $code $a1 default]} { + lappend a [list $a1 $default] + } else { + lappend a $a1 + } + } + set ach [linsert $a 0 ch] + return $code +} + +proc ::term::ansi::send::INIT {} { + foreach n [::term::ansi::code::ctrl::names] { + set nch [ChName $n] + set code [Args $n -> a ach av] + + if {[lindex $a end] eq "args"} { + # An args argument requires more care, and an eval + set av [lrange $av 0 end-1] + if {$av ne {}} {set av " $av"} + set gen "eval \[linsert \$args 0 $code$av\]" + #8.5: (written for clarity): set gen "$code$av {*}\$args" + } else { + set gen $code$av + } + + proc $n $a "wr \[$gen\]" ; namespace export $n + proc $nch $ach "wrch \$ch \[$gen\]" ; namespace export $nch + } + return +} + +namespace eval ::term::ansi::send { + namespace import ::term::send::wr + namespace import ::term::send::wrch + namespace export wr wrch +} + +::term::ansi::send::INIT + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::send 0.3 + +## +# ### ### ### ######### ######### ######### diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/bind.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/bind.tcl new file mode 100644 index 00000000..cd0b8600 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/bind.tcl @@ -0,0 +1,132 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - string -> action mappings +## (bind objects). For use with 'receive listen'. +## In essence a DFA with tree structure. + +# ### ### ### ######### ######### ######### +## Requirements + +package require snit +package require term::receive +namespace eval ::term::receive::bind {} + +# ### ### ### ######### ######### ######### + +snit::type ::term::receive::bind { + + constructor {{dict {}}} { + foreach {str cmd} $dict {Register $str $cmd} + return + } + + method map {str cmd} { + Register $str $cmd + return + } + + method default {cmd} { + set default $cmd + return + } + + # ### ### ### ######### ######### ######### + ## + + method listen {{chan stdin}} { + #parray dfa + ::term::receive::listen $self $chan + return + } + + method unlisten {{chan stdin}} { + ::term::receive::unlisten $chan + return + } + + # ### ### ### ######### ######### ######### + ## + + variable default {} + variable state {} + + method reset {} { + set state {} + return + } + + method next {c} {Next $c ; return} + method process {str} { + foreach c [split $str {}] {Next $c} + return + } + + method eof {} {Eof ; return} + + proc Next {c} { + upvar 1 dfa dfa state state default default + set key [list $state $c] + + #puts -nonewline stderr "('$state' x '$c')" + + if {![info exists dfa($key)]} { + # Unknown sequence. Reset. Restart. + # Run it through the default action. + + if {$default ne ""} { + uplevel #0 [linsert $default end $state$c] + } + + #puts stderr =\ RESET + set state {} + } else { + foreach {what detail} $dfa($key) break + #puts -nonewline stderr "= $what '$detail'" + if {$what eq "t"} { + # Incomplete sequence. Next state. + set state $detail + #puts stderr " goto ('$state')" + } elseif {$what eq "a"} { + # Action, then reset. + set state {} + #puts stderr " run ($detail)" + uplevel #0 [linsert $detail end $state$c] + } else { + return -code error \ + "Internal error. Bad DFA." + } + } + return + } + + proc Eof {} {} + + # ### ### ### ######### ######### ######### + ## + + proc Register {str cmd} { + upvar 1 dfa dfa + set prefix {} + set last {{} {}} + foreach c [split $str {}] { + set key [list $prefix $c] + set next $prefix$c + set dfa($key) [list t $next] + set last $key + set prefix $next + } + set dfa($last) [list a $cmd] + } + variable dfa -array {} + + ## + # ### ### ### ######### ######### ######### +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::receive::bind 0.2 + +## +# ### ### ### ######### ######### ######### diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/imenu.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/imenu.tcl new file mode 100644 index 00000000..c752027b --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/imenu.tcl @@ -0,0 +1,202 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - string -> action mappings +## (menu objects). For use with 'receive listen'. +## In essence a DFA with tree structure. + +# ### ### ### ######### ######### ######### +## Requirements + +package require snit +package require textutil::repeat +package require textutil::tabify +package require term::ansi::send +package require term::receive::bind +package require term::ansi::code::ctrl + +namespace eval ::term::receive::menu {} + +# ### ### ### ######### ######### ######### + +snit::type ::term::interact::menu { + + option -in -default stdin + option -out -default stdout + option -column -default 0 + option -line -default 0 + option -height -default 25 + option -actions -default {} + option -hilitleft -default 0 + option -hilitright -default end + option -framed -default 0 -readonly 1 + + # ### ### ### ######### ######### ######### + ## + + constructor {dict args} { + $self configurelist $args + Save $dict + + install bind using ::term::receive::bind \ + ${selfns}::bind $options(-actions) + + $bind map [cd::cu] [mymethod Up] + $bind map [cd::cd] [mymethod Down] + $bind map \n [mymethod Select] + #$bind default [mymethod DEF] + + return + } + + # ### ### ### ######### ######### ######### + ## + + method interact {} { + Show + $bind listen $options(-in) + vwait [myvar done] + $bind unlisten $options(-in) + return $map($done) + } + + method done {} {set done $at ; return} + method clear {} {Clear ; return} + + # ### ### ### ######### ######### ######### + ## + + component bind + + # ### ### ### ######### ######### ######### + ## + + variable map -array {} + variable header + variable labels + variable footer + variable empty + + proc Save {dict} { + upvar 1 header header labels labels footer footer + upvar 1 empty empty at at map map top top + upvar 1 options(-height) height + + set max 0 + foreach {l code} $dict { + if {[set len [string length $l]] > $max} {set max $len} + } + + set header [cd::groptim [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]] + set footer [cd::groptim [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc]] + + set labels {} + set at 0 + foreach {l code} $dict { + set map($at) $code + lappend labels ${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]] + incr at + } + + set h $height + if {$h > [llength $labels]} {set h [llength $labels]} + + set eline " [textutil::repeat::strRepeat { } $max]" + set empty $eline + for {set i 0} {$i <= $h} {incr i} { + append empty \n$eline + } + + set at 0 + set top 0 + return + } + + variable top 0 + variable at 0 + variable done . + + proc Show {} { + upvar 1 header header labels labels footer footer at at + upvar 1 options(-in) in options(-column) col top top + upvar 1 options(-out) out options(-line) row + upvar 1 options(-height) height options(-framed) framed + upvar 1 options(-hilitleft) left + upvar 1 options(-hilitright) right + + set bot [expr {$top + $height - 1}] + set fr [expr {$framed ? [cd::vl] : { }}] + + set text $header\n + set i $top + foreach l [lrange $labels $top $bot] { + append text $fr + if {$i != $at} { + append text $l + } else { + append text [string replace $l $left $right \ + [cd::sda_revers][string range $l $left $right][cd::sda_reset]] + } + append text $fr \n + incr i + } + append text $footer + + vt::wrch $out [cd::showat $row $col $text] + return + } + + proc Clear {} { + upvar 1 empty empty options(-column) col + upvar 1 options(-out) out options(-line) row + + vt::wrch $out [cd::showat $row $col $empty] + return + } + + # ### ### ### ######### ######### ######### + ## + + method Up {str} { + if {$at == 0} return + incr at -1 + if {$at < $top} {incr top -1} + Show + return + } + + method Down {str} { + upvar 0 options(-height) height + if {$at == ([llength $labels]-1)} return + incr at + set bot [expr {$top + $height - 1}] + if {$at > $bot} {incr top} + Show + return + } + + method Select {str} { + $self done + return + } + + method DEF {str} { + puts stderr "($str)" + exit + } + + ## + # ### ### ### ######### ######### ######### +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::term::interact::menu { + term::ansi::code::ctrl::import cd + term::ansi::send::import vt +} + +package provide term::interact::menu 0.2 + +## +# ### ### ### ######### ######### ######### diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ipager.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ipager.tcl new file mode 100644 index 00000000..47e5704a --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/ipager.tcl @@ -0,0 +1,206 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - string -> action mappings +## (pager objects). For use with 'receive listen'. +## In essence a DFA with tree structure. + +# ### ### ### ######### ######### ######### +## Requirements + +package require snit +package require textutil::repeat +package require textutil::tabify +package require term::ansi::send +package require term::receive::bind +package require term::ansi::code::ctrl + +namespace eval ::term::receive::pager {} + +# ### ### ### ######### ######### ######### + +snit::type ::term::interact::pager { + + option -in -default stdin + option -out -default stdout + option -column -default 0 + option -line -default 0 + option -height -default 25 + option -actions -default {} + + # ### ### ### ######### ######### ######### + ## + + constructor {str args} { + $self configurelist $args + Save $str + + install bind using ::term::receive::bind \ + ${selfns}::bind $options(-actions) + + $bind map [cd::cu] [mymethod Up] + $bind map [cd::cd] [mymethod Down] + $bind map \033\[5~ [mymethod PageUp] + $bind map \033\[6~ [mymethod PageDown] + $bind map \n [mymethod Done] + #$bind default [mymethod DEF] + + return + } + + # ### ### ### ######### ######### ######### + ## + + method interact {} { + Show + $bind listen $options(-in) + set interacting 1 + vwait [myvar done] + set interacting 0 + $bind unlisten $options(-in) + return + } + + method done {} {set done . ; return} + method clear {} {Clear ; return} + + method text {str} { + if {$interacting} {Clear} + Save $str + if {$interacting} {Show} + return + } + + # ### ### ### ######### ######### ######### + ## + + component bind + + # ### ### ### ######### ######### ######### + ## + + variable header + variable text + variable footer + variable empty + + proc Save {str} { + upvar 1 header header text text footer footer maxline maxline + upvar 1 options(-height) height empty empty at at + + set lines [split [textutil::tabify::untabify2 $str] \n] + + set max 0 + foreach l $lines { + if {[set len [string length $l]] > $max} {set max $len} + } + + set header [cd::groptim [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]] + set footer [cd::groptim [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc]] + + set text {} + foreach l $lines { + lappend text [cd::vl]${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]][cd::vl] + } + + set h $height + if {$h > [llength $text]} {set h [llength $text]} + + set eline " [textutil::repeat::strRepeat { } $max]" + set empty $eline + for {set i 0} {$i <= $h} {incr i} { + append empty \n$eline + } + + set maxline [expr {[llength $text] - $height}] + if {$maxline < 0} {set maxline 0} + set at 0 + return + } + + variable interacting 0 + variable at 0 + variable maxline -1 + variable done . + + proc Show {} { + upvar 1 header header text text footer footer at at + upvar 1 options(-in) in options(-column) col + upvar 1 options(-out) out options(-line) row + upvar 1 options(-height) height + + set to [expr {$at + $height -1}] + + vt::wrch $out [cd::showat $row $col \ + $header\n[join [lrange $text $at $to] \n]\n$footer] + return + } + + proc Clear {} { + upvar 1 empty empty options(-column) col + upvar 1 options(-out) out options(-line) row + + vt::wrch $out [cd::showat $row $col $empty] + return + } + + # ### ### ### ######### ######### ######### + ## + + method Up {str} { + if {$at == 0} return + incr at -1 + Show + return + } + + method Down {str} { + if {$at >= $maxline} return + incr at + Show + return + } + + method PageUp {str} { + set newat [expr {$at - $options(-height) + 1}] + if {$newat < 0} {set newat 0} + if {$newat == $at} return + set at $newat + Show + return + } + + method PageDown {str} { + set newat [expr {$at + $options(-height) - 1}] + if {$newat >= $maxline} {set newat $maxline} + if {$newat == $at} return + set at $newat + Show + return + } + + method Done {str} { + $self done + return + } + + method DEF {str} { + puts stderr "($str)" + exit + } + + ## + # ### ### ### ######### ######### ######### +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::term::interact::pager { + term::ansi::code::ctrl::import cd + term::ansi::send::import vt +} + +package provide term::interact::pager 0.2 + +## +# ### ### ### ######### ######### ######### diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/pkgIndex.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/pkgIndex.tcl new file mode 100644 index 00000000..2493ae7d --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/pkgIndex.tcl @@ -0,0 +1,13 @@ +if {![package vsatisfies [package provide Tcl] 8.5 9]} return +package ifneeded term 0.2 [list source [file join $dir term.tcl]] +package ifneeded term::ansi::code 0.3 [list source [file join $dir ansi/code.tcl]] +package ifneeded term::ansi::code::attr 0.2 [list source [file join $dir ansi/code/attr.tcl]] +package ifneeded term::ansi::code::ctrl 0.4 [list source [file join $dir ansi/code/ctrl.tcl]] +package ifneeded term::ansi::code::macros 0.2 [list source [file join $dir ansi/code/macros.tcl]] +package ifneeded term::ansi::ctrl::unix 0.1.2 [list source [file join $dir ansi/ctrlunix.tcl]] +package ifneeded term::ansi::send 0.3 [list source [file join $dir ansi/send.tcl]] +package ifneeded term::interact::menu 0.2 [list source [file join $dir imenu.tcl]] +package ifneeded term::interact::pager 0.2 [list source [file join $dir ipager.tcl]] +package ifneeded term::receive 0.2 [list source [file join $dir receive.tcl]] +package ifneeded term::receive::bind 0.2 [list source [file join $dir bind.tcl]] +package ifneeded term::send 0.2 [list source [file join $dir send.tcl]] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/receive.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/receive.tcl new file mode 100644 index 00000000..dfc56d6e --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/receive.tcl @@ -0,0 +1,60 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - Generic receiver operations + +# ### ### ### ######### ######### ######### +## Requirements + +namespace eval ::term::receive {} + +# ### ### ### ######### ######### ######### +## API. Read character from specific channel, +## or default (stdin). Processing of +## character sequences. + +proc ::term::receive::getch {{chan stdin}} { + return [read $chan 1] +} + +proc ::term::receive::listen {cmd {chan stdin}} { + fconfigure $chan -blocking 0 + fileevent $chan readable \ + [list ::term::receive::Foreach $chan $cmd] + return +} + +proc ::term::receive::unlisten {{chan stdin}} { + fileevent $chan readable {} + return +} + +# ### ### ### ######### ######### ######### +## Internals + +proc ::term::receive::Foreach {chan cmd} { + set string [read $chan] + if {[string length $string]} { + #puts stderr "F($string)" + uplevel #0 [linsert $cmd end process $string] + } + if {[eof $chan]} { + close $chan + uplevel #0 [linsert $cmd end eof] + } + return +} + +# ### ### ### ######### ######### ######### +## Initialization + +namespace eval ::term::receive { + namespace export getch listen +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::receive 0.2 + +## +# ### ### ### ######### ######### ######### diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/send.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/send.tcl new file mode 100644 index 00000000..4feaa119 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/send.tcl @@ -0,0 +1,34 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - Generic sender operations + +# ### ### ### ######### ######### ######### +## Requirements + +namespace eval ::term::send {} + +# ### ### ### ######### ######### ######### +## API. Write to channel, or default (stdout) + +proc ::term::send::wr {str} { + wrch stdout $str + return +} + +proc ::term::send::wrch {ch str} { + puts -nonewline $ch $str + flush $ch + return +} + +namespace eval ::term::send { + namespace export wr wrch +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::send 0.2 + +## +# ### ### ### ######### ######### ######### diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/term.tcl b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/term.tcl new file mode 100644 index 00000000..ec188d52 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/lib/term/term.tcl @@ -0,0 +1,19 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - Main :: Generic operations + +# Currently we have no generica at all. We make the package, but it +# provides nothing for now. + +# ### ### ### ######### ######### ######### +## Requirements + +namespace eval ::term {} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term 0.2 + +## +# ### ### ### ######### ######### ######### diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/README.md b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/README.md new file mode 100644 index 00000000..ed6e9672 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/README.md @@ -0,0 +1,24 @@ +This is primarily for tcl .tm modules required for your bootstrapping/make/build process. +It could include other files necessary for this process. + +The .tm modules here may be required for your build script if it intended the installation operator uses an existing tclsh or other shell as opposed to a tclkit you may have for distribution which is more likely to include necessary libraries. + +The modules here are loaded by your initialisation scripts and so can be a snapshot of different versions than those in your project src. +The modules can be your own, or 3rd party such as individual items from tcllib. + +You can copy modules from a running punk shell to this location using the dev command. + +e.g +dev lib.copyasmodule some::module::lib bootsupport + +The dev command will help you pick the latest version, and will create any necessary file structure matching the namespace of the package. + +e.g the result might be a file such as +/src/bootsupport/some/module/lib-0.1.tm + +The originating library may not yet be in .tm form. +You can copy a pkgIndex.tcl based library that is composed of a single .tcl file the same way using the above process and it will automatically name and file it appropriately but you need to check that the library doesn't require/load additional files - and that it is Tcl script only. + +Always verify that the library is copyable in this manner and test in a shell with tcl::tm::path pointed to ./bootsupport that it works. + + diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm index 1ede846b..b97d1b4e 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm @@ -10,7 +10,7 @@ # @@ Meta Begin # Application argparsingtest 0.1.0 # Meta platform tcl -# Meta license MIT +# Meta license MIT # @@ Meta End @@ -21,7 +21,7 @@ #[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 --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] #[require argparsingtest] #[keywords module] #[description] @@ -106,7 +106,7 @@ namespace eval argparsingtest { #*** !doctools #[subsection {Namespace argparsingtest}] - #[para] Core API functions for argparsingtest + #[para] Core API functions for argparsingtest #[list_begin definitions] proc test1_ni {args} { @@ -277,8 +277,8 @@ namespace eval argparsingtest { #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::get_dict comparative performance" + @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 @@ -298,7 +298,7 @@ namespace eval argparsingtest { punk::args::define { @id -id ::test1_punkargs_by_id - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @cmd -name argtest4 -help "test of punk::args::parse comparative performance" @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string @@ -320,7 +320,8 @@ namespace eval argparsingtest { punk::args::define { @id -id ::argparsingtest::test1_punkargs2 - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @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 @@ -333,18 +334,18 @@ namespace eval argparsingtest { -1 -default 1 -type boolean -2 -default 2 -type integer -3 -default 3 -type integer - @values - } + @values -min 0 -max 0 + } proc test1_punkargs2 {args} { - set argd [punk::args::get_by_id ::argparsingtest::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::get_dict { + set argd [punk::args::parse $args withdef { @id -id ::argparsingtest::test1_punkargs_validate_ansistripped - @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @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 @@ -358,7 +359,7 @@ namespace eval argparsingtest { -2 -default 2 -type integer -validate_ansistripped true -3 -default 3 -type integer -validate_ansistripped true @values - } $args] + }] return [tcl::dict::get $argd opts] } @@ -387,11 +388,11 @@ namespace eval argparsingtest { package require cmdline #cmdline::getoptions is much faster than typedGetoptions proc test1_cmdline_untyped {args} { - set cmdlineopts_untyped { - {return.arg "string" "return val"} + 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"} + {show_seps.arg \uFFEF "show table seps"} {join "join the things"} {x.arg "" "arg x"} {y.arg b "arg y"} @@ -405,11 +406,11 @@ namespace eval argparsingtest { return [::cmdline::getoptions args $cmdlineopts_untyped $usage] } proc test1_cmdline_typed {args} { - set cmdlineopts_typed { - {return.arg "string" "return val"} + 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"} + {show_seps.arg \uFFEF "show table seps"} {join "join the things"} {x.arg "" "arg x"} {y.arg b "arg y"} @@ -465,7 +466,7 @@ namespace eval argparsingtest { #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::get_dict [subst { + set argd [punk::args::parse $args withdef [subst { -template1 -default { ****** * t1 * @@ -476,7 +477,7 @@ namespace eval argparsingtest { * t2 * ******} -template3 -default {$t3} - #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately + #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately -template3b -default { $t3 ----------------- @@ -491,20 +492,52 @@ namespace eval argparsingtest { " -flag -default 0 -type boolean - }] $args] + }]] + 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]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" + # return "ok" #} @@ -524,14 +557,14 @@ namespace eval argparsingtest::lib { namespace path [namespace parent] #*** !doctools #[subsection {Namespace argparsingtest::lib}] - #[para] Secondary functions that are part of the API + #[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 + # #[para]Description of utility1 + # return 1 #} @@ -549,17 +582,17 @@ namespace eval argparsingtest::lib { namespace eval argparsingtest::system { #*** !doctools #[subsection {Namespace argparsingtest::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide argparsingtest [namespace eval argparsingtest { variable pkg argparsingtest variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/commandstack-0.3.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/commandstack-0.3.tm index 7884214c..b2561a20 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/commandstack-0.3.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/commandstack-0.3.tm @@ -99,8 +99,11 @@ namespace eval commandstack { } } - proc get_stack {command} { + 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] @@ -116,6 +119,7 @@ namespace eval commandstack { 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] diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/dictn-0.1.2.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/dictn-0.1.2.tm new file mode 100644 index 00000000..2ed2b1ef --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/dictn-0.1.2.tm @@ -0,0 +1,366 @@ +# -*- 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/vendor/punk/project-0.1/src/bootsupport/modules/modpod-0.1.2.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/modpod-0.1.3.tm similarity index 97% rename from src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/modpod-0.1.2.tm rename to src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/modpod-0.1.3.tm index aa27ebce..540a1696 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/modpod-0.1.2.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/modpod-0.1.3.tm @@ -7,7 +7,7 @@ # (C) 2024 # # @@ Meta Begin -# Application modpod 0.1.2 +# Application modpod 0.1.3 # Meta platform tcl # Meta license # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin modpod_module_modpod 0 0.1.2] +#[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 --}] @@ -134,12 +134,12 @@ namespace eval modpod { #old tar connect mechanism - review - not needed? proc connect {args} { puts stderr "modpod::connect--->>$args" - set argd [punk::args::get_dict { + 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)" - } $args] + }] catch { punk::lib::showdict $argd ;#heavy dependencies } @@ -168,7 +168,7 @@ namespace eval modpod { } else { #connect to .tm but may still be unwrapped version available - lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) + 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 @@ -225,11 +225,15 @@ namespace eval modpod { if {$connected(startdata,$modpodpath) >= 0} { #verify we have a valid tar header - if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { + 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 @@ -262,11 +266,12 @@ namespace eval modpod { return 1 } proc get {args} { - set argd [punk::args::get_dict { + set argd [punk::args::parse $args withdef { + @id -id ::modpod::get -from -default "" -help "path to pod" - *values -min 1 -max 1 + @values -min 1 -max 1 filename - } $args] + }] set frompod [dict get $argd opts -from] set filename [dict get $argd values filename] @@ -329,7 +334,7 @@ namespace eval modpod::lib { #zipfile is a pure zip at this point - ie no script/exe header proc make_zip_modpod {args} { - set argd [punk::args::get_dict { + 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. @@ -340,7 +345,7 @@ namespace eval modpod::lib { @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" - } $args] + }] set zipfile [dict get $argd values zipfile] set outfile [dict get $argd values outfile] set opt_offsettype [dict get $argd opts -offsettype] @@ -483,13 +488,15 @@ namespace eval modpod::system { 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 'zipfs mkimg' as at 2024-10 + #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 @@ -693,7 +700,7 @@ namespace eval modpod::system { package provide modpod [namespace eval modpod { variable pkg modpod variable version - set version 0.1.2 + set version 0.1.3 }] return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/oolib-0.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/oolib-0.1.tm new file mode 100644 index 00000000..3756fceb --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/oolib-0.1.tm @@ -0,0 +1,195 @@ +#JMN - api should be kept in sync with package patternlib where possible +# +package provide oolib [namespace eval oolib { + variable version + set version 0.1 +}] + +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]} { + 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 [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? + 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 {} { + 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/vendor/punk/project-0.1/src/bootsupport/modules/overtype-1.6.5.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/overtype-1.6.6.tm similarity index 99% rename from src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/overtype-1.6.5.tm rename to src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/overtype-1.6.6.tm index 9363fb6d..b4e59ec6 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/overtype-1.6.5.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/overtype-1.6.6.tm @@ -7,7 +7,7 @@ # (C) Julian Noble 2003-2023 # # @@ Meta Begin -# Application overtype 1.6.5 +# Application overtype 1.6.6 # Meta platform tcl # Meta license BSD # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin overtype_module_overtype 0 1.6.5] +#[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 --}] @@ -2713,7 +2713,8 @@ tcl::namespace::eval overtype { if {$idx > [llength $outcols]-1} { lappend outcols " " #tcl::dict::set understacks $idx [list] ;#review - use idx-1 codestack? - lset understacks $idx [list] + #lset understacks $idx [list] ;#will get index $i out of range error + lappend understacks [list] ;#REVIEW incr idx incr cursor_column } else { @@ -4765,7 +4766,7 @@ tcl::namespace::eval overtype { ## Ready package provide overtype [tcl::namespace::eval overtype { variable version - set version 1.6.5 + set version 1.6.6 }] return diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/pattern-1.2.4.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/pattern-1.2.4.tm index 6bc10b20..d6a9c932 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/pattern-1.2.4.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/pattern-1.2.4.tm @@ -5,13 +5,13 @@ # License: Public domain # -# "I need pattern" - Lexx Series 1 Episode 3 - Eating Pattern. +# "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, +# 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' @@ -21,9 +21,9 @@ # set [>object . myProperty .] blah # >object . myMethod blah # however, the property can also be read using: -# set [>object . myProperty .] +# set [>object . myProperty .] # Note the trailing . to give us a sort of 'reference' to the property. -# this is NOT equivalent to +# 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 @@ -32,7 +32,7 @@ #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 +#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) @@ -52,19 +52,19 @@ #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: +# 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 '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 +# , 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 @@ -100,16 +100,16 @@ # 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) +# 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 +#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 @@ -145,7 +145,7 @@ #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) +# 1.0.8.0 (passes 74/76) # tests now in own package # usage: # package require test::pattern @@ -155,12 +155,12 @@ #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. +# 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 +# +# +# miscellaneous tidy-ups # # 1.0.7.8 (passes 71/73) # @@ -171,8 +171,8 @@ #2005-09-07 # bugfix indexed write to list property # bugfix Variable default value -# 1.0.7.7 (passes 70/72) -# fails: +# 1.0.7.7 (passes 70/72) +# fails: # arrayproperty.test - array-entire-reference # properties.test - property_getter_filter_via_ObjectRef # @@ -200,7 +200,7 @@ # - 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 .] +# 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) @@ -213,7 +213,7 @@ # 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. @@ -225,7 +225,7 @@ # fix default property value append problem # #2004-07-17 -# add initial implementation of 'Unknown' and 'PatternUnknown' meta-methods +# add initial implementation of 'Unknown' and 'PatternUnknown' meta-methods # ( # #2004-06-18 @@ -236,18 +236,18 @@ # 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 . +# 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. +# 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 # @@ -257,9 +257,9 @@ package provide pattern [namespace eval pattern {variable version; set version 1 namespace eval pattern::util { - - # Generally better to use 'package require $minver-' - # - this only gives us a different error + + # 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 @@ -287,8 +287,8 @@ package require overtype namespace eval pattern { variable initialised 0 - - + + if 0 { if {![catch {package require twapi_base} ]} { #twapi is a windows only package @@ -296,7 +296,7 @@ namespace eval pattern { # 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 + 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) @@ -307,8 +307,8 @@ namespace eval pattern { } #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) } - - + + } @@ -344,7 +344,7 @@ proc process_pattern_aliases {object args} { #!store all interface objects here? -namespace eval ::p::ifaces {} +namespace eval ::p::ifaces {} @@ -358,18 +358,18 @@ namespace eval ::p::ifaces {} - + 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]] + 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 "" @@ -379,7 +379,7 @@ proc ::p::internals::(VIOLATE) {_ID_ violation_script} { 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] @@ -388,24 +388,24 @@ proc ::p::internals::(VIOLATE) {_ID_ violation_script} { 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" @@ -441,7 +441,7 @@ proc ::p::internals::DestroyObjectsBelowNamespace {ns} { - + @@ -465,7 +465,7 @@ proc ::p::internals::new_object {cmd {wrapped ""} {OID "-2"}} { } #if $wrapped provided it is assumed to be an existing namespace. #if {[string length $wrapped]} { - # #??? + # #??? #} #sanity check - alias must not exist for this OID @@ -473,9 +473,9 @@ proc ::p::internals::new_object {cmd {wrapped ""} {OID "-2"}} { error "Object alias '::p::$OID' already exists - cannot create new object with this id" } - #system 'varspaces' - + #system 'varspaces' - - #until we have a version of Tcl that doesn't have 'creative writing' scope issues - + #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 (?) @@ -487,11 +487,11 @@ proc ::p::internals::new_object {cmd {wrapped ""} {OID "-2"}} { namespace eval _iface { variable o_usedby; variable o_open 1; - array set o_usedby [list]; - variable o_varspace "" ; + array set o_usedby [list]; + variable o_varspace "" ; variable o_varspaces [list]; - variable o_methods [dict create]; - variable o_properties [dict create]; + variable o_methods [dict create]; + variable o_properties [dict create]; variable o_variables; variable o_propertyunset_handlers; set o_propertyunset_handlers [dict create] @@ -505,21 +505,21 @@ proc ::p::internals::new_object {cmd {wrapped ""} {OID "-2"}} { #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 - - + # - 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 @@ -528,10 +528,10 @@ proc ::p::internals::new_object {cmd {wrapped ""} {OID "-2"}} { # 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]" @@ -575,27 +575,27 @@ proc ::p::internals::new_object {cmd {wrapped ""} {OID "-2"}} { # the 1st item, blah in this case becomes the 'default' iStack. # #>x .*. -# cast to object with all iStacks +# cast to object with all iStacks # -#>x .*,!_. +#>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 +#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 +# 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 +#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 .] @@ -612,13 +612,13 @@ 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} { @@ -630,28 +630,28 @@ proc ::pattern::predatorversion {{ver ""}} { 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 + 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 + 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 + + rename ::p::predator$ver ::p::internals::predator set active_predatorversion $ver - + return $active_predatorversion } } @@ -681,8 +681,8 @@ proc ::pattern::init args { } } - #this seems out of date. - # - where is PatternPropertyRead? + #this seems out of date. + # - where is PatternPropertyRead? # - Object is obsolete # - Coinjoin, Combine don't seem to exist array set ::p::metaMethods { @@ -726,13 +726,13 @@ proc ::pattern::init args { 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 @@ -750,7 +750,7 @@ proc ::pattern::init args { ############################### - # OID = 1 + # OID = 1 # >pattern ############################### ::p::internals::new_object ::>pattern "" 1 @@ -761,12 +761,12 @@ proc ::pattern::init args { 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 @@ -784,7 +784,7 @@ proc ::pattern::init args { # >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_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] @@ -793,48 +793,48 @@ proc ::pattern::init args { array set ::p::2::_iface::o_definition [list] set ::p::2::_iface::o_open 1 ;#open for extending - ::p::ifaces::>2 .. AddInterface 2 + ::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 - + @@ -846,11 +846,11 @@ proc ::pattern::init args { #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 - + 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" @@ -877,7 +877,7 @@ proc ::pattern::init args { ::p::>interface .. PatternVarspace _iface - ::p::>interface .. PatternProperty methods + ::p::>interface .. PatternProperty methods ::p::>interface .. PatternPropertyRead methods {} { varspace _iface var {o_methods alias} @@ -891,7 +891,7 @@ proc ::pattern::init args { } ::p::>interface .. PatternProperty variables - ::p::>interface .. PatternProperty varspaces + ::p::>interface .. PatternProperty varspaces ::p::>interface .. PatternProperty definition @@ -933,7 +933,7 @@ proc ::pattern::init args { ::p::>interface .. PatternMethod open {} { varspace _iface var o_open - set o_open 1 + set o_open 1 } ::p::>interface .. PatternMethod close {} { varspace _iface @@ -950,7 +950,7 @@ proc ::pattern::init args { - + uplevel #0 {pattern::util::package_require_min patternlib 1.2.4} #uplevel #0 {package require patternlib} return 1 @@ -992,11 +992,11 @@ proc ::p::merge_interface {old new} { #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 + #interp alias {} ${ns_new}::$method {} ${ns_old}::$method #namespace eval $ns_new "namespace export [namespace tail $method]" } else { #wait to compile @@ -1014,18 +1014,18 @@ proc ::p::merge_interface {old 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 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]} { @@ -1050,23 +1050,23 @@ proc ::p::merge_interface {old new} { } - - + + #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 @@ -1075,13 +1075,13 @@ proc ::p::merge_interface {old new} { #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 } @@ -1093,15 +1093,15 @@ 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])" + 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] @@ -1109,13 +1109,13 @@ proc ::p::internals::commandrefMisuse_TraceHandler {OID field args} { #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])" + 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 "$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 } @@ -1130,9 +1130,9 @@ proc ::p::internals::commandrefMisuse_TraceHandler {OID field args} { #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 +# ::p::@IID@ $methprop @oid@ {*}$args # }] -# return +# return #} @@ -1142,7 +1142,7 @@ proc ::p::internals::commandrefMisuse_TraceHandler {OID field args} { ################################################################################################################################################ ################################################################################################################################################ -#aliased from ::p::${OID}:: +#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'" @@ -1157,7 +1157,7 @@ proc ::p::internals::expand_interface {IID {force 0}} { 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 + ::p::>interface .. Create ::p::ifaces::>$iid return $iid } else { if {[set ::p::${IID}::_iface::o_open]} { @@ -1167,13 +1167,13 @@ proc ::p::internals::expand_interface {IID {force 0}} { 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::>interface .. Create ::p::ifaces::>$IID ::p::internals::linkcopy_interface $prev_IID $IID #assert: prev_usedby contains at least one other element. @@ -1193,7 +1193,7 @@ proc ::p::internals::linkcopy_interface {old new} { set ns_new ::p::${new}::_iface - + foreach nsmethod [info commands ${ns_old}::*.1] { #puts ">>> adding $nsmethod to iface $new" set tail [namespace tail $nsmethod] @@ -1208,7 +1208,7 @@ proc ::p::internals::linkcopy_interface {old new} { #!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? @@ -1216,7 +1216,7 @@ proc ::p::internals::linkcopy_interface {old new} { 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 #} @@ -1232,14 +1232,14 @@ proc ::p::internals::linkcopy_interface {old 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 @@ -1259,21 +1259,21 @@ proc ::p::internals::linkcopy_interface {old new} { #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' - + + #leave ::(usedby) reference in place for caller to change as appropriate - 'copy' + return } ################################################################################################################################################ diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk-0.1.tm index 68a14411..6fb185a9 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk-0.1.tm @@ -1,4 +1,4 @@ -#Punk - where radical modification is a craft and anti-patterns are another exploratory tool for the Pattern Punk. +#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. @@ -6,8 +6,8 @@ namespace eval punk { proc lazyload {pkg} { package require zzzload if {[package provide $pkg] eq ""} { - zzzload::pkg_require $pkg - } + zzzload::pkg_require $pkg + } } #lazyload twapi ? @@ -50,9 +50,9 @@ namespace eval punk { } - proc ::punk::auto_execok_original name [info body ::auto_execok] + 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 @@ -141,6 +141,7 @@ namespace eval punk { } if {[llength [file split $name]] != 1} { + #has a path foreach ext $execExtensions { set file ${name}${ext} if {[file exists $file] && ![file isdirectory $file]} { @@ -164,21 +165,45 @@ namespace eval punk { } foreach var {PATH Path path} { - if {[info exists env($var)]} { - append path ";$env($var)" - } + if {[info exists env($var)]} { + append path ";$env($var)" + } } #change2 - set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}] + 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]} { @@ -209,7 +234,7 @@ namespace eval punk { #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 and is an example of the problem this addresses @@ -223,9 +248,9 @@ namespace eval punk { 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' + #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)] && @@ -261,13 +286,13 @@ namespace eval punk { return [file join $windowsappdir $name] } if {$cmdexedir eq ""} { - #cmd.exe very unlikely to move + #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) + #anyway.. it has other side effects (affects auto_load) } return "[file join $cmdexedir cmd.exe] /c $name" - } + } return $default_auto }] @@ -279,9 +304,9 @@ namespace eval punk { #repltelemetry cooperation with other packages such as shellrun -#Maintenance warning: shellrun expects repltelemetry_emmitters to exist if punk namespace exists +#Maintenance warning: shellrun expects repltelemetry_emmitters to exist if punk namespace exists namespace eval punk { - variable repltelemetry_emmitters + 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] @@ -376,7 +401,7 @@ if {![llength [info commands ::ansistring]]} { package require punk::aliascore ;#mostly punk::lib aliases punk::aliascore::init -force 1 -package require punk::repl::codethread +package require punk::repl::codethread package require punk::config #package require textblock package require punk::console ;#requires Thread @@ -385,6 +410,9 @@ package require punk::winpath ;# for windows paths - but has functions that can package require punk::repo package require punk::du package require punk::mix::base +package require base64 + +package require punk::pipe namespace eval punk { # -- --- --- @@ -415,7 +443,7 @@ namespace eval punk { package require shellfilter package require punkapp package require funcl - + package require struct::list package require fileutil #package require punk::lib @@ -435,8 +463,8 @@ namespace eval punk { #----------------------------------- # todo - load initial debug state from config debug off punk.unknown - debug level punk.unknown 1 - debug off punk.pipe + 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 @@ -478,7 +506,7 @@ namespace eval punk { uplevel 1 [list set $varname $obj2] } - interp alias "" strlen "" ::punk::strlen + interp alias "" strlen "" ::punk::strlen interp alias "" str_len "" ::punk::strlen interp alias "" objclone "" ::punk::objclone #proc ::strlen {str} { @@ -487,6 +515,7 @@ namespace eval punk { #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 @@ -502,6 +531,351 @@ namespace eval punk { 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} { @@ -563,22 +937,24 @@ namespace eval punk { #get last command result that was run through the repl proc ::punk::get_runchunk {args} { - set argd [punk::args::get_dict { + 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 + -1 -optional 1 -type none + -2 -optional 1 -type none @values -min 0 -max 0 - } $args] + }] #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] + lappend sortlist [list $num $cname] } - set sorted [lsort -index 0 -integer $sortlist] + set sorted [lsort -index 0 -integer $sortlist] set chunkname [lindex $sorted end-1 1] set runlist [tsv::get repl $chunkname] #puts stderr "--$runlist" @@ -635,10 +1011,10 @@ namespace eval punk { set inopts 1 } else { #leave loop at first nonoption - i should be index of file - break + break } } else { - #leave for next iteration to check + #leave for next iteration to check set inopts 0 } incr i @@ -654,44 +1030,8 @@ namespace eval punk { set ::argc $argc return -code $code $return } - #https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ - # - #we can't provide a float comparison suitable for every situation, - #but we pick something reasonable, keep it stable, and document it. - proc float_almost_equal {a b} { - package require math::constants - set diff [expr {abs($a - $b)}] - if {$diff <= $math::constants::eps} { - return 1 - } - set A [expr {abs($a)}] - set B [expr {abs($b)}] - set largest [expr {($B > $A) ? $B : $A}] - return [expr {$diff <= $largest * $math::constants::eps}] - } - #boolean could be tr, true, y, ye, yes,Yes, 1 , 0 etc. - proc boolean_equal {a b} { - #equivalenttly xnor: expr {!(($a && 1) ^ ($b && 1))} ;# less clear and no discernable timing benefit. - expr {($a && 1) == ($b && 1)} - } - #debatable whether boolean_almost_equal is likely to be surprising or helpful. - #values from a calculation that are extremely close to zero but aren't false could also be surprising - especially if they compare equal numerically - #perhaps a fuzzy-boolean is a step too far for a default - but it's inline with float-comparison for pattern-matching. use an even more complex classifier? (^&~) ? - proc boolean_almost_equal {a b} { - if {[string is double -strict $a]} { - if {[float_almost_equal $a 0]} { - set a 0 - } - } - if {[string is double -strict $b]} { - if {[float_almost_equal $b 0]} { - set b 0 - } - } - #must handle true,no etc. - expr {($a && 1) == ($b && 1)} - } + proc varinfo {vname {flag ""}} { @@ -703,9 +1043,9 @@ namespace eval punk { error "can't read \"$vname\": no such variable" } set inf [shellfilter::list_element_info [list $v]] - set inf [dict get $inf 0] + set inf [dict get $inf 0] if {$flag eq "-v"} { - return $inf + return $inf } set output [dict create] @@ -781,7 +1121,7 @@ namespace eval punk { } else { append token $c if {$c eq "("} { - set in_brackets 1 + set in_brackets 1 } } } @@ -791,162 +1131,12 @@ namespace eval punk { } return $varlist } - proc splitstrposn {s p} { - if {$p <= 0} { - if {$p == 0} { - list "" $s - } else { - list $s "" - } - } else { - scan $s %${p}s%s - } - } - proc splitstrposn_nonzero {s p} { - scan $s %${p}s%s - } - #split top level of patterns only. - proc _split_patterns_memoized {varspecs} { - set name_mapped [pipecmd_namemapping $varspecs] - set cmdname ::punk::pipecmds::split_patterns::_$name_mapped - if {[info commands $cmdname] ne ""} { - return [$cmdname] - } - set result [_split_patterns $varspecs] - proc $cmdname {} [list return $result] - #debug.punk.pipe.compile {proc $cmdname} 4 - return $result - } - proc _split_patterns {varspecs} { - - set varlist [list] - # @ @@ - list and dict functions - # / level separator - # # list count, ## dict size - # % string functions - # ! not - set var_terminals [list "@" "/" "#" "%" "!" ">" "<"] ;# (> required for insertionspecs at rhs of = & .= ) - #right bracket ) also ends a var - but is different depending on whether var is array or basic. For array - it forms part of the varname - - #except when prefixed directly by pin classifier ^ - set protect_terminals [list "^"] ;# e.g sequence ^# - #also - an atom usually doesn't need the / as a terminal - because it can't match a missing element unless it's empty string - #ie the one usecase is '/n to match either empty string or missing item at position n. For this one usecase - we miss the capability to atom match paths/urls .. '/usr/local/et' - set in_brackets 0 ;#count depth - set in_atom 0 - #set varspecs [string trimleft $varspecs ,] - set token "" - #if {[string first "," $varspecs] <0} { - # return $varspecs - #} - set first_term -1 - set token_index 0 ;#index of terminal char within each token - set indq 0 - set inesc 0 ;#whether last char was backslash (see also punk::escv) - set prevc "" - set char_index 0 - foreach c [split $varspecs ""] { - if {$indq} { - if {$inesc} { - #puts stderr "inesc adding '$c'" - append token $c - } else { - if {$c eq {"}} { - set indq 0 - } else { - append token $c - } - } - } elseif {$in_atom} { - #ignore dquotes/brackets in atoms - pass through - append token $c - #set nextc [lindex $chars $char_index+1] - if {$c eq "'"} { - set in_atom 0 - } - } elseif {$in_brackets > 0} { - append token $c - if {$c eq ")"} { - incr in_brackets -1 - } - } else { - if {$c eq {"} && !$inesc} { - set indq 1 - } elseif {$c eq ","} { - #lappend varlist [splitstrposn $token $first_term] - set var $token - set spec "" - if {$first_term > 0} { - #tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. - #lassign [scan $token %${first_term}s%s] var spec - set var [string range $token 0 $first_term-1] - set spec [string range $token $first_term end] ;#key section includes the terminal char which ended the var and starts the spec - } else { - if {$first_term == 0} { - set var "" - set spec $token - } - } - lappend varlist [list [string trim $var] [string trim $spec]] - set token "" - set token_index -1 ;#reduce by 1 because , not included in next token - set first_term -1 - } else { - append token $c - switch -exact -- $c { - ' { - set in_atom 1 - } - ( { - incr in_brackets - } - default { - if {$first_term == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} { - set first_term $token_index - } - } - } - } - } - set prevc $c - if {$c eq "\\"} { - #review - if {$inesc} { - set inesc 0 - } else { - set token [string range $token 0 end-1] - set inesc 1 - } - } else { - set inesc 0 - } - incr token_index - incr char_index - } - if {[string length $token]} { - #lappend varlist [splitstrposn $token $first_term] - set var $token - set spec "" - if {$first_term > 0} { - #lassign [scan $token %${first_term}s%s] var spec - set var [string range $token 0 $first_term-1] - set spec [string range $token $first_term end] ;#key section includes the terminal char which ended the var and starts the spec - } else { - if {$first_term == 0} { - set var "" - set spec $token - } - } - lappend varlist [list [string trim $var] [string trim $spec]] - } - return $varlist - } proc _split_var_key_at_unbracketed_comma {varspecs} { set varlist [list] set var_terminals [list "@" "/" "#" "!"] #except when prefixed directly by pin classifier ^ - set protect_terminals [list "^"] ;# e.g sequence ^# + set protect_terminals [list "^"] ;# e.g sequence ^# #also - an atom usually doesn't need the / as a terminal - because it can't match a missing element unless it's empty string #ie the one usecase is '/n to match either empty string or missing item at position n. For this one usecase - we miss the capability to atom match paths/urls .. '/usr/local/et' set in_brackets 0 @@ -966,27 +1156,17 @@ namespace eval punk { } } else { if {$c eq ","} { - #lappend varlist [splitstrposn $token $first_term] - set var $token - set spec "" - if {$first_term > 0} { - lassign [scan $token %${first_term}s%s] var spec - } else { - if {$first_term == 0} { - set var "" - set spec $token - } - } - lappend varlist [list $var $spec] + lappend varlist [punk::lib::string_splitbefore $token $first_term] + set token "" set token_index -1 ;#reduce by 1 because , not included in next token set first_term -1 } else { append token $c if {$first_term == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} { - set first_term $token_index + set first_term $token_index } elseif {$c eq "("} { - set in_brackets 1 + set in_brackets 1 } } } @@ -994,18 +1174,7 @@ namespace eval punk { incr token_index } if {[string length $token]} { - #lappend varlist [splitstrposn $token $first_term] - set var $token - set spec "" - if {$first_term > 0} { - lassign [scan $token %${first_term}s%s] var spec - } else { - if {$first_term == 0} { - set var "" - set spec $token - } - } - lappend varlist [list $var $spec] + lappend varlist [punk::lib::string_splitbefore $token $first_term] } return $varlist } @@ -1029,6 +1198,7 @@ namespace eval punk { } else { if {$c eq ","} { if {$first_term > -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] @@ -1041,12 +1211,12 @@ namespace eval punk { } else { if {$first_term == -1} { if {$c in $var_terminals} { - set first_term $token_index + set first_term $token_index } } append token $c if {$c eq "("} { - set in_brackets 1 + set in_brackets 1 } } } @@ -1067,7 +1237,7 @@ namespace eval punk { proc fp_restructure {selector data} { if {$selector eq ""} { fun=.= {val $input} 0 || abs($offset) >= $len)} { set action ?mismatch-list-index-out-of-range break @@ -1424,7 +1594,7 @@ namespace eval punk { } elseif {$start eq "end"} { #ok } elseif {$do_bounds_check} { - set startoffset [string range $start 3 end] ;#include the - from end- + 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 @@ -1481,7 +1651,7 @@ namespace eval punk { } 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] @@ -1513,23 +1683,40 @@ namespace eval punk { 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 + #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 - set selector_safe [string map [list ? * {$} "" "\x1b\[" "\x1b\]" {[} {]} :: {;} " " \t \n \r ] $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] @@ -1553,8 +1740,8 @@ namespace eval punk { 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 {}}] + #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 @@ -1562,7 +1749,7 @@ namespace eval punk { #append script \n {set assigned ""} ;#review set active_key_type "" append script \n {# set active_key_type ""} - set lhs "" + set lhs "" #append script \n [tstr {set lhs ${{$lhs}}}] append script \n {set lhs ""} set rhs "" @@ -1582,9 +1769,9 @@ namespace eval punk { #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]} { + + if {![string length $selector]} { #just return $leveldata set script { dict create -assigned $leveldata -action ?match -lhs "" -rhs $leveldata @@ -1598,7 +1785,7 @@ namespace eval punk { #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 + #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 # @@ -1625,7 +1812,7 @@ namespace eval punk { # -- --- --- } if {[string match @@* $selector]} { - #part following a double @ is dict key possibly with forward-slash separators for subpath access e.g @@key/subkey/etc + #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 /] @@ -1659,11 +1846,11 @@ namespace eval punk { 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] /] + 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" - + append script \n "set lhs {$index}" + set assigned "" append script \n {set assigned ""} @@ -1677,21 +1864,21 @@ namespace eval punk { # 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. + #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 + 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 + #not a list - not-length is true set assigned 1 } else { - #is a list - not-length is false + #is a list - not-length is false set assigned 0 } } @@ -1710,7 +1897,7 @@ namespace eval punk { #dict size set active_key_type "dict" if {$get_not} { - lappend INDEX_OPERATIONS not-dict + 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}]} { @@ -1733,10 +1920,10 @@ namespace eval punk { } %# { set active_key_type "string" - if $get_not { + if {$get_not} { error "!%# not string length is not supported" } - #string length - REVIEW - + #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]} @@ -1745,10 +1932,10 @@ namespace eval punk { %%# { #experimental set active_key_type "string" - if $get_not { + if {$get_not} { error "!%%# not string length is not supported" } - #string length - REVIEW - + #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]} @@ -1756,7 +1943,7 @@ namespace eval punk { } %str { set active_key_type "string" - if $get_not { + if {$get_not} { error "!%str - not string-get is not supported" } lappend INDEX_OPERATIONS string-get @@ -1767,7 +1954,7 @@ namespace eval punk { %sp { #experimental set active_key_type "string" - if $get_not { + if {$get_not} { error "!%sp - not string-space is not supported" } lappend INDEX_OPERATIONS string-space @@ -1778,7 +1965,7 @@ namespace eval punk { %empty { #experimental set active_key_type "string" - if $get_not { + if {$get_not} { error "!%empty - not string-empty is not supported" } lappend INDEX_OPERATIONS string-empty @@ -1788,10 +1975,10 @@ namespace eval punk { } @words { set active_key_type "string" - if $get_not { + if {$get_not} { error "!%words - not list-words-from-string is not supported" } - lappend INDEX_OPERATIONS list-words-from-string + 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 @@ -1800,10 +1987,10 @@ namespace eval punk { #experimental - leading character based on result not input(?) #input type is string - but output is list set active_key_type "list" - if $get_not { + if {$get_not} { error "!%chars - not list-chars-from-string is not supported" } - lappend INDEX_OPERATIONS list-from_chars + 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 @@ -1812,7 +1999,7 @@ namespace eval punk { #experimental - flatten one level of list #join without arg - output is list set active_key_type "string" - if $get_not { + if {$get_not} { error "!@join - not list-join-list is not supported" } lappend INDEX_OPERATIONS list-join-list @@ -1824,7 +2011,7 @@ namespace eval punk { #experimental #input type is list - but output is string set active_key_type "string" - if $get_not { + if {$get_not} { error "!%join - not string-join-list is not supported" } lappend INDEX_OPERATIONS string-join-list @@ -1834,7 +2021,7 @@ namespace eval punk { } %ansiview { set active_key_type "string" - if $get_not { + if {$get_not} { error "!%# not string-ansiview is not supported" } lappend INDEX_OPERATIONS string-ansiview @@ -1844,7 +2031,7 @@ namespace eval punk { } %ansiviewstyle { set active_key_type "string" - if $get_not { + if {$get_not} { error "!%# not string-ansiviewstyle is not supported" } lappend INDEX_OPERATIONS string-ansiviewstyle @@ -1855,23 +2042,23 @@ namespace eval punk { @ { #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) + #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 $keyglob] { # set active_key_type "dict" index_operation: globkey-get-pairs-not - set matched [dict keys $leveldata ] + set matched [dict keys $leveldata {}] set assigned [dict remove $leveldata {*}$matched] }] @@ -2285,7 +2473,7 @@ namespace eval punk { 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 matched [dict keys $leveldata {}] set assigned [dict create] foreach m $matched { dict set assigned $m [dict get $leveldata $m] @@ -2307,7 +2495,7 @@ namespace eval punk { 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 matched [dict keys $leveldata {}] set assigned [dict keys [dict remove $leveldata {*}$matched]] }] @@ -2315,7 +2503,7 @@ namespace eval punk { 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 assigned [dict keys $leveldata {}] }] } set level_script_complete 1 @@ -2323,7 +2511,7 @@ namespace eval punk { {@k\*@*} - {@K\*@*} { #dict value glob - return keys set active_key_type "dict" - set keyglob [string range $index 4 end] + 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]} @@ -2331,22 +2519,22 @@ namespace eval punk { }] if {$get_not} { lappend INDEX_OPERATIONS globvalue-get-keys-not - append script \n [string map [list $keyglob] { + 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]} { + if {![string match {} $v]} { lappend assigned $k } } }] } else { lappend INDEX_OPERATIONS globvalue-get-keys - append script \n [string map [list $keyglob] { + 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]} { + if {[string match {} $v]} { lappend assigned $k } } @@ -2357,7 +2545,7 @@ namespace eval punk { {@.\*@*} { #dict value glob - return pairs set active_key_type "dict" - set keyglob [string range $index 4 end] + 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]} @@ -2365,22 +2553,22 @@ namespace eval punk { }] if {$get_not} { lappend INDEX_OPERATIONS globvalue-get-pairs-not - append script \n [string map [list $keyglob] { + 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]} { + if {![string match {} $v]} { dict set assigned $k $v } } }] } else { lappend INDEX_OPERATIONS globvalue-get-pairs - append script \n [string map [list $keyglob] { + 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]} { + if {[string match {} $v]} { dict set assigned $k $v } } @@ -2389,9 +2577,9 @@ namespace eval punk { set level_script_complete 1 } {@V\*@*} - {@v\*@*} { - #dict value glob - return values + #dict value glob - return values set active_key_type dict - set keyglob [string range $index 4 end] + 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]} @@ -2399,11 +2587,11 @@ namespace eval punk { }] if {$get_not} { lappend INDEX_OPERATIONS globvalue-get-values-not - append script \n [string map [list $keyglob] { + 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]} { + if {![string match {} $v]} { lappend assigned $v } } @@ -2411,9 +2599,9 @@ namespace eval punk { } else { lappend INDEX_OPERATIONS globvalue-get-values - append script \n [string map [list $keyglob] { + append script \n [string map [list $valglob] { # set active_key_type "dict" ;#index_operation: globvalue-get-value - set assigned [dict values $leveldata ] + set assigned [dict values $leveldata ] }] } set level_script_complete 1 @@ -2437,14 +2625,14 @@ namespace eval punk { # 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]} { + if {[string match {} $k] || [string match {} $v]} { dict set assigned $k $v } } }] } - - error "globkeyvalue-get-pairs todo" + set level_script_complete 1 + puts stderr "globkeyvalue-get-pairs review" } @* { set active_key_type "list" @@ -2483,7 +2671,7 @@ namespace eval punk { 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 @@ -2544,7 +2732,7 @@ namespace eval punk { ${[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} + ${$assignment_script} } }] } @@ -2568,7 +2756,7 @@ namespace eval punk { #set action ?mismatch-list-index-out-of-range ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} } else { - ${$assignment_script} + ${$assignment_script} } }] } else { @@ -2577,13 +2765,13 @@ namespace eval punk { #set action ?mismatch-not-a-list ${[tstr -ret string $tpl_return_mismatch_not_a_list]} } else { - ${$assignment_script} + ${$assignment_script} } }] } } tail { - #NOTE: /@tail and /tail both do bounds check. This is intentional. + #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. @@ -2596,7 +2784,7 @@ namespace eval punk { 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 @@ -2693,7 +2881,7 @@ namespace eval punk { } raw { #get_not - return nothing?? - #no list checking.. + #no list checking.. if {$get_not} { lappend INDEX_OPERATIONS getraw-not append script \n {set assigned {}} @@ -2748,7 +2936,7 @@ namespace eval punk { } else { lappend INDEX_OPERATIONS list-getpairs } - append script \n [tstr -return string -allowcommands { + 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]} @@ -2776,7 +2964,7 @@ namespace eval punk { if {[catch {llength $leveldata} len]} { ${[tstr -ret string $tpl_return_mismatch_not_a_list]} } else { - ${$assign_script} + ${$assign_script} } }] } elseif {[string is integer -strict $index]} { @@ -2816,7 +3004,7 @@ namespace eval punk { #set action ?mismatch-not-a-list ${[tstr -ret string $tpl_return_mismatch_not_a_list]} } else { - ${$assign_script} + ${$assign_script} } }] } @@ -2847,7 +3035,7 @@ namespace eval punk { #set action ?mismatch-list-index-out-of-range ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} } else { - ${$assign_script} + ${$assign_script} } } }] @@ -2857,7 +3045,7 @@ namespace eval punk { #set action ?mismatch-not-a-list ${[tstr -ret string $tpl_return_mismatch_not_a_list]} } else { - ${$assign_script} + ${$assign_script} } }] } @@ -2896,15 +3084,15 @@ namespace eval punk { } elseif {$start eq "end"} { #noop } else { - set startoffset [string range $start 3 end] ;#include the - from end- + 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} + 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]} @@ -2916,7 +3104,7 @@ namespace eval punk { 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} + 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]} @@ -2932,7 +3120,7 @@ namespace eval punk { 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} + 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]} @@ -3014,13 +3202,13 @@ namespace eval punk { } 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 @@ -3072,7 +3260,7 @@ namespace eval punk { #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" @@ -3096,7 +3284,7 @@ namespace eval punk { } incr i_keyindex append script \n "# ------- END index $index ------" - } ;# end foreach + } ;# end foreach @@ -3109,157 +3297,6 @@ namespace eval punk { return $script } - #todo - recurse into bracketed sub parts - #JMN3 - #e.g @*/(x@0,y@2) - proc _var_classify {multivar} { - set cmdname ::punk::pipecmds::var_classify::_[pipecmd_namemapping $multivar] - if {[info commands $cmdname] ne ""} { - return [$cmdname] - } - - - #comma seems a natural choice to split varspecs, - #but also for list and dict subelement access - #/ normally indicates some sort of hierarchical separation - (e.g in filesytems) - #so / will indicate subelements e.g @0/1 for lindex $list 0 1 - #set valsource_key_list [_split_var_key_at_unbracketed_comma $multivar] - set valsource_key_list [_split_patterns_memoized $multivar] - - - - #mutually exclusive - atom/pin - #set map [list "" ' ^ &] ;#0 = default/var/not-yet-determined 1 = atom 2 = pin - #set var_class [lmap var $valsource_key_list {expr {([set m [lsearch $map [string index [lindex $var 0] 0]]] >= 0) ? [list $var $m] : [list $var 0]}}] - #0 - novar - #1 - atom ' - #2 - pin ^ - #3 - boolean & - #4 - integer - #5 - double - #6 - var - #7 - glob (no classifier and contains * or ?) - #8 - numeric - #9 - > (+) - #10 - < (-) - - set var_names [list] - set var_class [list] - set varspecs_trimmed [list] ;#raw varspecs without pin/atom modifiers - or empty string for glob - - - set leading_classifiers [list "'" "&" "^" ] - set trailing_classifiers [list + -] - set possible_number_start [list - + . 0 1 2 3 4 5 6 7 8 9 > <] - - foreach v_key $valsource_key_list { - lassign $v_key v key - set vname $v ;#default - set classes [list] - if {$v eq ""} { - lappend var_class [list $v_key 0] - lappend varspecs_trimmed $v_key - } else { - set lastchar [string index $v end] - switch -- $lastchar { - + { - lappend classes 9 - set vname [string range $v 0 end-1] - } - - { - lappend classes 10 - set vname [string range $v 0 end-1] - } - } - set firstchar [string index $v 0] - switch -- $firstchar { - ' { - lappend var_class [list $v_key 1] - #set vname [string range $v 1 end] - lappend varspecs_trimmed [list $vname $key] - } - ^ { - lappend classes [list 2] - #use vname - may already have trailing +/- stripped - set vname [string range $vname 1 end] - set secondclassifier [string index $v 1] - switch -- $secondclassifier { - "&" { - #pinned boolean - lappend classes 3 - set vname [string range $v 2 end] - } - "#" { - #pinned numeric comparison instead of string comparison - #e.g set x 2 - # this should match: ^#x.= list 2.0 - lappend classes 8 - set vname [string range $vname 1 end] - } - "*" { - #pinned glob - lappend classes 7 - set vname [string range $v 2 end] - } - } - #todo - check for second tag - & for pinned boolean? - #consider requiring ^# for numeric comparisons. currently no way to do a strictly string comparison on pinned variables.... default ^var really shouldn't be doing any magic. - #while we're at it.. pinned glob would be nice. ^* - #maybe even pinned scan ^% ? regex? ^/ or ^? these would be hard to have corresponding literals in the pattern mini-lang. - #These all limit the range of varnames permissible - which is no big deal. - lappend var_class [list $v_key $classes] - lappend varspecs_trimmed [list $vname $key] - } - & { - #we require boolean literals to be single-quoted so we can use cross-binding on boolean vars. - #ie &true is the variable true whereas &'true' or &'1' &'t' etc are literal booleans - #allow exception of &1 &0 to be literal booleans - because we disallow 0 & 1 as varnames in other contexts anyway - so it would be more consistent not to treat as varnames here. - lappend var_class [list $v_key 3] - set vname [string range $v 1 end] - lappend varspecs_trimmed [list $vname $key] - } - default { - if {([string first ? $v]) >=0 || ([string first * $v] >=0)} { - lappend var_class [list $v_key 7] ;#glob - #leave vname as the full glob - lappend varspecs_trimmed [list "" $key] - } else { - #scan vname not v - will either be same as v - or possibly stripped of trailing +/- - set numtestv [join [scan $vname %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, decimal points and sci notation - fails to handle leading dot e.g .5 - #leading . still need to test directly for double - if {[string is double -strict $vname] || [string is double -strict $numtestv]} { - if {[string is integer -strict $numtestv]} { - #this will pick up boolean 1 or 0 - but that's ok - they require "&" marker if boolean comparison desired - #integer test before double.. - #note there is also string is wide (string is wideinteger) for larger ints.. - lappend classes 4 - lappend var_class [list $v_key $classes] - lappend varspecs_trimmed $v_key - } else { - #double - #sci notation 1e123 etc - #also large numbers like 1000000000 - even without decimal point - (tcl bignum) - lappend classes 5 - lappend var_class [list $v_key $classes] - lappend varspecs_trimmed $v_key - } - } else { - lappend var_class [list $v_key 6] ;#var - lappend varspecs_trimmed $v_key - } - } - } - } - } - lappend var_names $vname - } - - set result [list var_names $var_names var_class $var_class varspecs_trimmed $varspecs_trimmed] - - proc $cmdname {} [list return $result] - debug.punk.pipe.compile {proc $cmdname} - return $result - } @@ -3269,41 +3306,41 @@ namespace eval punk { #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) + #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 + #'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 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] + 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 [_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 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 + 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 } @@ -3314,7 +3351,7 @@ namespace eval punk { #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" @@ -3329,18 +3366,18 @@ namespace eval punk { #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: + #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 + # 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 @@ -3355,7 +3392,7 @@ namespace eval punk { # ^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 + # 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] @@ -3396,8 +3433,8 @@ namespace eval punk { 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 - + #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 @@ -3424,7 +3461,7 @@ namespace eval punk { 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 @@ -3445,7 +3482,7 @@ namespace eval punk { 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 + 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} @@ -3473,7 +3510,7 @@ namespace eval punk { ##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} { @@ -3502,7 +3539,7 @@ namespace eval punk { # - 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 + #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" @@ -3512,7 +3549,7 @@ namespace eval punk { 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] @@ -3522,7 +3559,7 @@ namespace eval punk { #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 + #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 @@ -3533,10 +3570,10 @@ namespace eval punk { 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 + #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 @@ -3561,7 +3598,7 @@ namespace eval punk { lset expected_values $i [list var $varname spec $lhsspec info failread-$varname lhs ? rhs $val] break } - } + } } @@ -3583,7 +3620,7 @@ namespace eval punk { if {[string index $lhs 0] eq "."} { set testlhs $lhs } else { - set testlhs [join [scan $lhs %lld%s] ""] + set testlhs [join [scan $lhs %lld%s] ""] } if {[string index $val 0] eq "."} { set testval $val @@ -3648,10 +3685,10 @@ namespace eval punk { } } 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 . + #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. + #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. # @@ -3682,7 +3719,7 @@ namespace eval punk { } } } else { - if {[punk::float_almost_equal $testlhs $testval]} { + if {[punk::pipe::float_almost_equal $testlhs $testval]} { lset match_state $i 1 } else { if {$isgreaterthan} { @@ -3709,7 +3746,7 @@ namespace eval punk { } } } else { - #e.g rhs not a number.. + #e.g rhs not a number.. if {$testlhs == $testval} { lset match_state $i 1 } else { @@ -3721,7 +3758,7 @@ namespace eval punk { } elseif {$isdouble} { #dragons (and shimmering) # - # + # if {$ispin} { set existing_expected [lindex $expected_values $i] set lhs [dict get $existing_expected lhs] @@ -3761,7 +3798,7 @@ namespace eval punk { } } 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::float_almost_equal $lhs $testval]} { + 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 { @@ -3777,7 +3814,7 @@ namespace eval punk { # 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::boolean_equal $a $b + #punk::pipe::boolean_equal $a $b set extra_match_info "" ;# possible crossbind indication set is_literal_boolean 0 if {$ispin} { @@ -3789,7 +3826,7 @@ namespace eval punk { set lhs [string range $lhsspec 1 end] ;# - strip off & classifier prefix if {![string length $lhs]} { - #empty varname - ok + #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" @@ -3813,7 +3850,7 @@ namespace eval punk { 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} + #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] @@ -3846,7 +3883,7 @@ namespace eval punk { #may have already matched above..(for variable) if {[lindex $match_state $i] != 1} { - if {![catch {punk::boolean_almost_equal $lhs $val} ismatch]} { + 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] @@ -3880,11 +3917,11 @@ namespace eval punk { } } elseif {$ispin} { - #handled above.. leave case in place so we don't run else for pins + #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! + #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) @@ -3904,7 +3941,7 @@ namespace eval punk { } default { set first_bound [lsearch -index 0 $var_actions $varname] - #assertion first_bound >=0, we will always find something - usually self + #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 @@ -3964,7 +4001,7 @@ namespace eval punk { 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 + upvar $lvlup $varname the_var set the_var [lindex $var_actions $i 2] } } @@ -3976,7 +4013,7 @@ namespace eval punk { # 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 + # upvar $lvlup $varname the_var # if {$act eq "set"} { # set the_var $val # } @@ -3990,7 +4027,8 @@ namespace eval punk { #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 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 ""} { @@ -3999,7 +4037,9 @@ namespace eval punk { lappend var_display_names $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]]} ]}}] + #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" @@ -4015,12 +4055,12 @@ namespace eval punk { #6 - var #7 - glob (no classifier and contains * or ?) foreach mismatchinfo $mismatches { - lassign $mismatchinfo status varname + 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 e [dict get [lindex $expected_values $i] lhs] set type "" if {2 in $varclass} { append type "pinned " @@ -4098,7 +4138,7 @@ namespace eval punk { return [dict get $d result] } } - # initially promising - but the approach runs into impossible disambiguation of mismatch as data vs an actual mismatch + # 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 @@ -4122,55 +4162,43 @@ namespace eval punk { 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] + 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] + 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 cmdcopy [punk::objclone $args] set nscaller [uplevel 1 [list namespace current]] tailcall interp alias {} $targetcmd {} apply [list args [concat "\[concat" [list $cmdcopy] "\$args]"] $nscaller] } - #map rhs to names suitable to use in pipemcd proc name (whitespace mapping) - # (for .= and = pipecmds) - proc pipecmd_namemapping {rhs} { - #used to build a command from a pattern which could contain :: - we need to map it to keep it a single command in the desired namespace. - #glob chars will prevent us using simple test {[info commands $cmd] eq ""} to test existence - #we could use the test {$cmd in [info commands]} - but mapping away globchars is more robust, allowing the simpler test - set rhs [string trim $rhs];#ignore all leading & trailing whitespace - set rhs [regsub -all {\s{1,}} $rhs {}] ;#collapse all internal whitespace to a single token - set rhs [tcl::string::map {: ? * } $rhs] - #review - we don't expect other command-incompatible chars such as colon? - return $rhs - } #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 {^([^\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! + #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 [pipecmd_namemapping $equalsrhs] + 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 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 @@ -4189,10 +4217,10 @@ namespace eval punk { #NOTE: #we need to ensure for case: - #= x=y + #= 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 = + #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. @@ -4202,7 +4230,7 @@ namespace eval punk { # 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 - + #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 @@ -4210,7 +4238,7 @@ namespace eval punk { #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= <| # x= |> #both leave x empty. To assign a pipelike value to x we would have to do: x= <| |> (equiv: set x |>) foreach a $args { @@ -4239,14 +4267,14 @@ namespace eval punk { # 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 [_split_equalsrhs $equalsrhs] + 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 + # 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 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? @@ -4259,7 +4287,7 @@ namespace eval punk { #Here, we are not assigning to v1 - but matching the index spec /0 with the data from v1 #ie Y is inserted at position 0 to get A Y #(Note the difference from lhs) - #on lhs v1/1= {X Y} + #on lhs v1/1= {X Y} #would pattern match against the *data* A B and set v1 to B #in this point of an assign (= as opposed to .=) IF we have already determined there is no trailing pipeline @@ -4268,10 +4296,10 @@ namespace eval punk { #eg out= list a $callervar c #or alternatively use .= instead # - #HOWEVER - we need to build/compile a script that could then have further pipeline elements supplied as arguments + #HOWEVER - we need to build/compile a script that could then have further pipeline elements supplied as arguments #At the moment - this is handled in the script above by diverting to punk::pipeline to handle #The only vars/data we can possibly have to insert, come from the ] }] - set needs_insertion 0 + 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]} { + 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] + set d [punk::_multi_bind_result {} $segmenttail] #return [punk::_handle_bind_result $d] - #maintenance: inlined + #maintenance: inlined if {![dict exists $d result]} { #uplevel 1 [list error [dict get $d mismatch]] #error [dict get $d mismatch] @@ -4356,7 +4384,7 @@ namespace eval punk { tailcall $pipecmd {*}$args } - #return a script for inserting data into listvar + #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 "*"] @@ -4384,15 +4412,15 @@ namespace eval punk { } 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} { + if {$isint} { append script [string map [list $listvar $index] { if {( > [llength $])} { - #not a pipesyntax error + #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? + #todo check end-x bounds? } if {$isint} { append script [string map [list $listvar $index $exp $data] { @@ -4455,98 +4483,20 @@ namespace eval punk { }] } - + } 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 } - #todo - consider whether we can use < for insertion/iteration combinations - # =a<,b< iterate once through - # =a><,b>< cartesian product - # =a<>,b<> ??? zip ? - # - # ie = {a b c} |> .=< inspect - # would call inspect 3 times, once for each argument - # .= list {a b c} {x y z} |a/0,b/1> .=a><,b>< list - # would produce list of cartesian pairs? - # - proc _split_equalsrhs {insertionpattern} { - #map the insertionpattern so we can use faster globless info command search - set name_mapped [pipecmd_namemapping $insertionpattern] - set cmdname ::punk::pipecmds::split_rhs::_$name_mapped - if {[info commands $cmdname] ne ""} { - return [$cmdname] - } - - set lst_var_indexposition [punk::_split_patterns_memoized $insertionpattern] - set i 0 - set return_triples [list] - foreach v_pos $lst_var_indexposition { - lassign $v_pos v index_and_position - #e.g varname@@data/ok>0 varname/1/0>end - #ensure only one ">" is detected - if {![string length $index_and_position]} { - set indexspec "" - set positionspec "" - } else { - set chars [split $index_and_position ""] - set posns [lsearch -all $chars ">"] - if {[llength $posns] > 1} { - error "pipesyntax error in segment insertion pattern '$insertionpattern' -v '$v' multiple '>' characters. Pattern not understood." "_split_equalsrhs $insertionpattern" [list pipesyntax insertionpattern_invalid] - } - if {![llength $posns]} { - set indexspec $index_and_position - set positionspec "" - } else { - set splitposn [lindex $posns 0] - set indexspec [string range $index_and_position 0 $splitposn-1] - set positionspec [string range $index_and_position $splitposn+1 end] - } - } - - #review - - if {($positionspec in [list "*" "/*" "@*" "/" "@"]) || ($v eq "*" && $positionspec eq "")} { - set star "" - if {$v eq "*"} { - set v "" - set star "*" - } - if {[string index $positionspec end] eq "*"} { - set star "*" - } - #it is always possible to insert at end of list regardless of current length - so /end* and @end* are equivalent - #as are /end and @end - #lset lst_var_indexposition $i [list $v "/end$star"] - set triple [list $v $indexspec "/end$star"] - } else { - if {$positionspec eq ""} { - #e.g just =varname - #lset lst_var_indexposition $i [list $v "/end"] - set triple [list $v $indexspec "/end"] - #error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' missing position spec e.g /0" - } else { - if {[string index $indexspec 0] ni [list "" "/" "@"]} { - error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' bad index spec '$indexspec'" "_split_equalsrhs $insertionpattern" [list pipesyntax insertionpattern_invalid] - } - set triple [list $v $indexspec $positionspec] - } - } - lappend return_triples $triple - incr i - } - proc $cmdname {} [list return $return_triples] - return $return_triples - } - proc _is_math_func_prefix {e1} { #also catch starting brackets.. e.g "(min(4,$x) " if {[regexp {^[^[:alnum:]]*([[:alnum:]]*).*} $e1 _ word]} { - #possible math func + #possible math func if {$word in [info functions]} { return true } @@ -4583,8 +4533,8 @@ namespace eval punk { #puts "PERCENTS : $percents" set sequences [list] set in_sequence 0 - set start -1 - set end -1 + 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 @@ -4601,7 +4551,7 @@ namespace eval punk { } else { if {$n ^ $p} { incr s_length - incr end + incr end } else { if {$n & $p} { if {$s_length == 1} { @@ -4612,7 +4562,7 @@ namespace eval punk { set start $i set end $i } else { - incr end + incr end lappend sequences [list $start $end] set in_sequence 0 set s_length 0 @@ -4649,81 +4599,11 @@ namespace eval punk { return $output } - # - # - # relatively slow on even small sized scripts - proc arg_is_script_shaped2 {arg} { - set re {^(\s|;|\n)$} - set chars [split $arg ""] - if {[lsearch -regex $chars $re] >=0} { - return 1 - } else { - return 0 - } - } - - #exclude quoted whitespace - proc arg_is_script_shaped {arg} { - if {[tcl::string::first \n $arg] >= 0} { - return 1 - } elseif {[tcl::string::first ";" $arg] >= 0} { - return 1 - } elseif {[tcl::string::first " " $arg] >= 0 || [tcl::string::first \t $arg] >= 0} { - lassign [_rhs_tail_split $arg] _ part2 ;#will have part2 if unquoted whitespace found - return [expr {$part2 ne ""}] - } else { - return 0 - } - } - proc _rhs_tail_split {fullrhs} { - set inq 0; set indq 0 - set equalsrhs "" - set i 0 - foreach ch [split $fullrhs ""] { - if {$inq} { - append equalsrhs $ch - if {$ch eq {'}} { - set inq 0 - } - } elseif {$indq} { - append equalsrhs $ch - if {$ch eq {"}} { - set indq 0 - } - } else { - switch -- $ch { - {'} { - set inq 1 - } - {"} { - set indq 1 - } - " " { - #whitespace outside of quoting - break - } - 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 {} - default { - #\t not a literal for switch jumpTable bytecompile - review - can we do it without for example string mapping to (and without a literal binary tab in source file)? - #we can't (reliably?) put \t as one of our switch keys - # - if {$ch eq "\t"} { - break - } - } - } - append equalsrhs $ch - } - incr i - } - set tail [tcl::string::range $fullrhs $i end] - return [list $equalsrhs $tail] - } # -- #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 ~* + #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 = @@ -4739,12 +4619,14 @@ namespace eval punk { #--------------------------------------------------------------------- # 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 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 @@ -4773,9 +4655,9 @@ namespace eval punk { #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 - + #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 + #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: @@ -4784,7 +4666,8 @@ namespace eval punk { #var1 will contain ETC (from entire pipeline), var2 will contain etc (from associated segment) # - if {([set nexteposn [string first = $next1]] >= 0) && (![arg_is_script_shaped $next1]) } { + 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 {.}} { @@ -4794,7 +4677,7 @@ namespace eval punk { #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]} { #} @@ -4819,17 +4702,17 @@ namespace eval punk { 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 |> + #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 " and/or <| elements. + set argpipe [lindex $fulltail $firstargpipe_posn] + set argpipespec [string range $argpipe 1 end-1] ;# strip off < & | from " 0}] #if {$segment_has_insertions} { # puts stdout ">>> $segment_members insertion_patterns $insertion_patterns" @@ -4994,7 +4877,7 @@ namespace eval punk { 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 + #already potentially overridden continue } dict set dict_tagval $vname $val @@ -5010,7 +4893,7 @@ namespace eval punk { #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 + set segment_members_filled $segment_members if {[dict exists $dict_tagval data]} { lappend segment_members_filled [dict get $dict_tagval data] } @@ -5020,7 +4903,7 @@ namespace eval punk { set segment_members_filled [list] set segmenttail $segment_members ;# todo - change to segment_members here to match punk::match_assign - set rhsmapped [pipecmd_namemapping $rhs] + 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 ""} { @@ -5057,13 +4940,14 @@ namespace eval punk { } if {[dict exists $dict_tagval $v]} { set insertion_data [dict get $dict_tagval $v] - #todo - use destructure_func + #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] } @@ -5098,9 +4982,9 @@ namespace eval punk { #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? + set rhs [string map $dict_tagval $rhs] ;#obsolete? debug.punk.pipe.rep {segment_members_filled rep: [rep $segment_members_filled]} 4 @@ -5109,8 +4993,8 @@ namespace eval punk { #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 - + #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] @@ -5119,25 +5003,25 @@ namespace eval punk { #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! + #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} |> = + #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 + 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] @@ -5168,7 +5052,7 @@ namespace eval punk { 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 @@ -5255,7 +5139,7 @@ namespace eval punk { #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 @@ -5265,17 +5149,17 @@ namespace eval punk { #examine tailremaining. # either x x x |?> y y y ... # or just y y y - #we want the x side for next loop - + #we want the x side for next loop + #set up the conditions for the next loop - #|> x=y args + #|> x=y args # inpipespec - contents of previous piper |xxx> # outpipespec - empty or content of subsequent piper |xxx> - # previous_result + # previous_result # assignment (x=y) - set pipespec($j,in) $pipespec($i,out) + set pipespec($j,in) $pipespec($i,out) set outpipespec "" set tailmap "" set next_pipe_posn -1 @@ -5295,7 +5179,7 @@ namespace eval punk { 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 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 { @@ -5311,7 +5195,7 @@ namespace eval punk { set rhs "" set segment_first_is_script 0 if {[llength $next_all_members]} { - if {[arg_is_script_shaped [lindex $next_all_members 0]]} { + 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 "" @@ -5322,7 +5206,7 @@ namespace eval punk { 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 [arg_is_script_shaped $segment_first_word] + 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 .= } @@ -5330,7 +5214,7 @@ namespace eval punk { } elseif {[regexp {^([^ \t\r\n=]*)=(.*)} $possible_assignment _ returnvarspec rhs]} { set segment_op "=" #never scripts - #must be at most a single element after the = ! + #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] @@ -5341,7 +5225,7 @@ namespace eval punk { } 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 @@ -5357,7 +5241,7 @@ namespace eval punk { } else { #?? two pipes in a row ? - debug.punk.pipe {[a+ yellow bold]WARNING: no segment members found[a]} 0 + debug.punk.pipe {[a+ yellow bold]WARNING: no segment members found[a]} 0 set segment_members return set segment_first_word return } @@ -5369,7 +5253,7 @@ namespace eval punk { } 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} { @@ -5382,7 +5266,7 @@ namespace eval punk { set more_pipe_segments 0 } - #the segment_result is based on the leftmost var on the lhs of the .= + #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] @@ -5414,7 +5298,7 @@ namespace eval punk { } set s $posn } else { - #int + #int if {($start < 0) || ($start > ($datalen -1))} { return 0 } @@ -5430,7 +5314,7 @@ namespace eval punk { } set e $posn } else { - #int + #int if {($end < 0)} { return 0 } @@ -5448,7 +5332,7 @@ namespace eval punk { if {$e < $s} { return 0 } - + return [expr {$e - $s + 1}] } @@ -5601,11 +5485,11 @@ namespace eval punk { #windows experiment todo - use twapi and named pipes - #twapi::namedpipe_server {\\.\pipe\something} + #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 { @@ -5619,8 +5503,8 @@ namespace eval punk { #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 {[dict get $::punk::config::running auto_exec_mechanism] eq "experimental"} { + + 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 @@ -5628,16 +5512,16 @@ namespace eval punk { #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 + 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 + 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. + #no point returning "exitcode 0" if that's the only non-error return. #It is misleading. Better to return empty string. set ::tcl::UnknownResult "" } @@ -5647,10 +5531,10 @@ namespace eval punk { 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 + #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 + #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} { @@ -5747,7 +5631,7 @@ namespace eval punk { } } - + } return -code error -errorcode [list TCL LOOKUP COMMAND $name] "invalid command name $name" @@ -5756,11 +5640,12 @@ namespace eval punk { 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. + ##This means we can't have 2 different conds with same body if we test for body in unknown. ##if {$body ni $existing} { - package require base64 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} { @@ -5779,7 +5664,6 @@ namespace eval punk { } proc decodescript {b64} { if {[ catch { - package require base64 base64::decode $b64 } scr]} { return "" @@ -5817,36 +5701,36 @@ namespace eval punk { 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 - - #---------------- - #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} - #---------------- + #can't use know - because we don't want to return before original unknown body is called. proc ::unknown {args} [string cat { - package require base64 #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] + 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 + #exitcode must be the first key know {[lindex $args 0 0] eq "exitcode"} { uplevel 1 [list exitcode {*}[lrange [lindex $args 0] 1 end]] } @@ -5854,13 +5738,13 @@ namespace eval punk { #----------------------------- # - # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. - + # 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 + #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} @@ -5879,18 +5763,18 @@ namespace eval punk { 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 + #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 [_rhs_tail_split $fullrhs] equalsrhs tail + 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'= + # 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::_split_patterns_memoized $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] @@ -5904,27 +5788,27 @@ namespace eval punk { } else { set nscaller [uplevel 1 [list ::namespace current]] #jmn - set rhsmapped [pipecmd_namemapping $equalsrhs] + 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...? + #warn for now...? #tailcall $pattern=$equalsrhs {*}$args tailcall $pattern=$rhsmapped {*}$tail } } #puts "--->nscurrent [uplevel 1 [list ::namespace current]]" - #ignore the namespace.. + #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=\{]*)=(.*)} + #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 @@ -5992,12 +5876,12 @@ namespace eval punk { 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 + #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 [_rhs_tail_split $fullrhs] equalsrhs argstail + lassign [punk::pipe::lib::_rhs_tail_split $fullrhs] equalsrhs argstail } #tailcall ::punk::match_assign $pattern $equalsrhs {*}$argstail @@ -6018,8 +5902,8 @@ namespace eval punk { 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 + #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: @@ -6033,14 +5917,14 @@ namespace eval punk { #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 + #the #know {[regexp $punk::re_dot_assign [lindex $args 0 0] partzerozero varspecs rhs]} { @@ -6048,17 +5932,17 @@ namespace eval punk { # #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 + 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 + #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 @@ -6068,12 +5952,12 @@ namespace eval punk { tailcall {*}[list ::punk::pipeline = "" "" {*}$arglist] } - set is_script [punk::arg_is_script_shaped $assign] + 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 re_equals {^([^ \t\r\n=\{]*)=$} #set dumbeditor {\}} if {[regexp {^([^ \t\r\n=\{]*)\.=$} $assign _ returnvarspecs]} { set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] @@ -6092,7 +5976,7 @@ namespace eval punk { tailcall {*}$cmdlist - #result-based mismatch detection can probably never work nicely.. + #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] @@ -6128,10 +6012,10 @@ namespace eval punk { set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] } elseif {$assign eq "="} { set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] - } elseif {![punk::arg_is_script_shaped $assign] && [string index $assign end] eq "="} { + } 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 re_equals {^([^ \t\r\n=\{]*)=$} # set dumbeditor {\}} if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] @@ -6143,10 +6027,10 @@ namespace eval punk { } } else { set cmdlist $args - #script? + #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 @@ -6236,7 +6120,7 @@ namespace eval punk { } } - #should only raise an error for pipe syntax errors - all other errors should be wrapped + #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] @@ -6245,10 +6129,10 @@ namespace eval punk { } elseif {$assign eq "="} { #set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] set cmdlist [list ::= {*}$arglist] - } elseif {![punk::arg_is_script_shaped $assign] && [string first "=" $assign] >= 0} { + } 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 re_equals {^([^ \t\r\n=\{]*)=$} #set dumbeditor {\}} if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { @@ -6257,15 +6141,15 @@ namespace eval punk { set cmdlist [list $assign {*}$arglist] #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] } else { - error "pipesyntax pipecase unable to interpret pipeline '$args'" + error "pipesyntax pipecase unable to interpret pipeline '$args'" } #todo - account for insertion-specs e.g x=* x.=/0* } else { - #script? + #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] @@ -6308,14 +6192,14 @@ namespace eval punk { return [dict create error [dict create suppressed $result]] } default { - #normal tcl error + #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]] + tailcall return -errorcode [list casematch] [dict create ok [dict create result $result]] } } @@ -6329,7 +6213,7 @@ namespace eval punk { #unset args #upvar args upargs #set upargs $nextargs - upvar switchargs switchargs + upvar switchargs switchargs set switchargs $args uplevel 1 [::list ::if 1 $pipescript] } @@ -6339,7 +6223,7 @@ namespace eval punk { proc pipeswitchc {pipescript args} { set binding {} if {[info level] == 1} { - #up 1 is global + #up 1 is global set get_vars [list info vars] } else { set get_vars [list info locals] @@ -6377,13 +6261,13 @@ namespace eval punk { % - pipematch - ispipematch { incr i set e2 [lindex $args $i] - #set body [list $e {*}$e2] + #set body [list $e {*}$e2] #append body { $data} - - set body [list $e {*}$e2] + + set body [list $e {*}$e2] append body { {*}$data} - - + + set applylist [list {data} $body] #puts stderr $applylist set r [apply $applylist $r] @@ -6393,7 +6277,7 @@ namespace eval punk { incr i set e2 [lindex $args $i] set body [list $e $e2] - #pipeswitch takes 'args' - so expand $data when in pipedata context + #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. @@ -6421,8 +6305,7 @@ namespace eval punk { proc scriptlibpath {{shortname {}} args} { - upvar ::punk::config::running running_config - set scriptlib [dict get $running_config scriptlib] + set scriptlib [punk::config::configure running scriptlib] if {[string match "lib::*" $shortname]} { set relpath [string map [list "lib::" "" "::" "/"] $shortname] set relpath [string trimleft $relpath "/"] @@ -6452,7 +6335,7 @@ namespace eval punk { if {$::tcl_platform(platform) eq "windows"} { set sep ";" } else { - # : ok for linux/bsd ... mac? + # : ok for linux/bsd ... mac? set sep ":" } set cond [string map [list $glob] {expr {[string length $item] && [string match $item]}}] @@ -6465,7 +6348,7 @@ namespace eval punk { } proc path {{glob *}} { set pipe [punk::path_list_pipe $glob] - {*}$pipe |> list_as_lines + {*}$pipe |> list_as_lines } #------------------------------------------------------------------- @@ -6508,7 +6391,7 @@ namespace eval punk { #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. + #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} { @@ -6526,7 +6409,7 @@ namespace eval punk { 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 + #protect with \\?\ to stop windows api from parsing #will do nothing if already prefixed with \\?\ set a2 [punk::winpath::illegalname_fix $a2] @@ -6536,7 +6419,7 @@ namespace eval punk { switch -- $a1 { -b { #dubious utility on FreeBSD, windows? - #FreeBSD has dropped support for block devices - stating 'No serious applications rely on block devices' + #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"}] @@ -6545,7 +6428,7 @@ namespace eval punk { } } -c { - #e.g on windows CON,NUL + #e.g on windows CON,NUL if {[file exists $a2]} { set boolresult [expr {[file type $a2] eq "characterSpecial"}] } else { @@ -6559,9 +6442,9 @@ namespace eval punk { set boolresult [file exists $a2] } -f { - #e.g on windows CON,NUL + #e.g on windows CON,NUL if {[file exists $a2]} { - set boolresult [expr {[file type $a2] eq "file"}] + set boolresult [expr {[file type $a2] eq "file"}] } else { set boolresult false } @@ -6621,7 +6504,7 @@ namespace eval punk { } "-eq" { #test expects a possibly-large integer-like thing - #shell scripts will + #shell scripts will if {![is_sh_test_integer $a1]} { puts stderr "sh_TEST: invalid integer '$a1'" set lasterr 2 @@ -6725,7 +6608,7 @@ namespace eval punk { 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 + set lasterr $exitcode } if {$exitcode == 0} { set boolresult true @@ -6761,7 +6644,7 @@ namespace eval punk { 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 + #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 { @@ -6801,7 +6684,7 @@ namespace eval 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? + #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. @@ -6857,7 +6740,7 @@ namespace eval punk { 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" @@ -6957,7 +6840,7 @@ namespace eval punk { #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. + #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. # @@ -7046,7 +6929,7 @@ namespace eval punk { } #group_numlist ? preserve representation of numbers rather than use string comparison? - + # - group_string #.= punk::group_string "aabcccdefff" @@ -7131,7 +7014,7 @@ namespace eval punk { #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 + #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] @@ -7147,7 +7030,7 @@ namespace eval punk { set filtered_list [list] set binding {} if {[info level] == 1} { - #up 1 is global + #up 1 is global set get_vars [list ::info vars] } else { set get_vars [list ::info locals] @@ -7227,38 +7110,89 @@ namespace eval punk { return $linelist } - - #An implementation of a notoriously controversial metric. - proc LOC {args} { - set argspecs [subst { + 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 \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } - }] - set argd [punk::args::get_dict $argspecs $args] - lassign [dict values $argd] leaders opts vals - set searchspecs [dict values $vals] + " { + @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_dir [dict get $opts -dir] + # -- --- --- --- --- --- + 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_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 {*}$searchspecs] + 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 [list] + 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 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 @@ -7267,111 +7201,318 @@ namespace eval punk { 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 [linelist -line {trimright} -block {trimall} [fcat $fpath]]] + set floc [llength $lines] + set comparedlines $lines } else { - set lines [linelist -line {trimright} -block {trimall} [fcat $fpath]] 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 {[file tail $fpath] in $seentails} { - set isdupfile 1 - incr dupfilecount - incr dupfileloc $floc + 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 } - lappend seentails [file tail $fpath] + 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} { - return [list loc $loc filecount [llength $filepaths] dupfiles $dupfilecount dupfileloc $dupfileloc extensions $extensions purepunctuationlines $purepunctlines] + 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 [list loc $loc filecount [llength $filepaths] dupfiles $dupfilecount dupfileloc $dupfileloc extensions $extensions] + 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 + #!!!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 opts [lrange $args 1 end] ;#todo set nlsplit [split $data \n] set rootindent -1 set stepindent -1 - #set wordlike_parts [regexp -inline -all {\S+} $lastitem] - set d [dict create] - set keys [list] - set i 1 - set firstkeyline "N/A" - set firststepline "N/A" + + #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]]} { - incr i continue } - set is_rootkey 0 + + #todo - use info complete to accept keys/values with newlines regexp {(\s*)(.*)} $ln _ space linedata - puts stderr ">>line:'$ln' [string length $space] $linedata" - set this_indent [string length $space] - if {$rootindent < 0} { - set firstkeyline $ln - set rootindent $this_indent + 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 {$this_indent == $rootindent} { - set is_rootkey 1 + 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" } - if {$this_indent < $rootindent} { - error "bad root indentation ($this_indent) at line: $i smallest indent was set by first key line: $firstkeyline" + #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 {$is_rootkey} { - dict set d $linedata {} - lappend keys $linedata + 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 { - if {$stepindent < 0} { - set stepindent $this_indent - set firststepline $ln + #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 == $stepindent} { - dict set d [lindex $keys end] $ln + 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 { - if {($this_indent % $stepindent) != 0} { - error "bad indentation ($this_indent) at line: $i not a multiple of the first key indent $step_indent seen on $firststepline" - } + dict set indents_seen $this_indent 1 + } + } + } + - #todo fix! + #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] - lappend keys [list $parentkey $ln] - set oldval [dict get $d $parentkey] - if {[string length $oldval]} { - set new [dict create $oldval $ln] + 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 { - dict set d $parentkey $ln - } - + #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 {} } } - incr i + #puts ">>keys:$keys" } return $d } - proc dictline {d} { + proc dictline {d {indent 2}} { puts stderr "unimplemented" set lines [list] - + return $lines } @@ -7414,79 +7555,79 @@ namespace eval punk { @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 - " + 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 - " + 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... + 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 + - 385 - For no limit - use -limit -1 - " + 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. - " + 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)" + 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" + 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." + 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" - } + 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." + 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 -" + 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\ @@ -7500,7 +7641,7 @@ namespace eval punk { 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 flags [lrange $args 0 $endoptsposn-1] set pipeargs [lrange $args $endoptsposn+1 end] } else { #no explicit end of opts marker @@ -7551,7 +7692,7 @@ namespace eval punk { set val [lindex $pipeargs 0] set count 1 } else { - #but the pipeline segment could have an insertion-pattern ending in * + #but the pipeline segment could have an insertion-pattern ending in * set val $pipeargs set count [llength $pipeargs] } @@ -7597,7 +7738,7 @@ namespace eval punk { set ansibase [dict get $opts -ansibase] if {$ansibase ne ""} { - #-ansibase default is hardcoded into punk::args definition + #-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 @@ -7609,27 +7750,31 @@ namespace eval punk { set displayval $ansibase[punk::ansi::ansistrip $displayval] } 1 { - #val may have ansi - including resets. Pass through ansibase_lines to + #val may have ansi - including resets. Pass through ansibase_lines to if {$ansibase ne ""} { - set displayval [::textblock::ansibase_lines $displayval $ansibase] + #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 [::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 [::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 [::textblock::ansibase_lines $displayval $ansibase] + set displayval [punk::ansi::ansiwrap_raw $ansibase "" "" $displayval] } } } @@ -7665,6 +7810,7 @@ namespace eval punk { 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"] @@ -7692,9 +7838,9 @@ namespace eval punk { $t configure_column 1 -minwidth [expr {$width_1 + 1}] $t configure -title $title - set text "" + set text "" append text [$t print] - + set warningblock "" set introblock $mascotblock @@ -7743,14 +7889,14 @@ namespace eval punk { upvar ::punk::config::other_env_vars_config otherenv_config set known_punk [dict keys $punkenv_config] - set known_other [dict keys $otherenv_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 + #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. @@ -7759,7 +7905,7 @@ namespace eval punk { #do an array read on ::env foreach {v vinfo} $punkenv_config { if {[info exists ::env($v)]} { - set c2 [set ::env($v)] + set c2 [set ::env($v)] } else { set c2 "(NOT SET)" } @@ -7778,7 +7924,7 @@ namespace eval punk { 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 c2 [set ::env($v)] + set c2 [set ::env($v)] } else { set c2 "(NOT SET)" } @@ -7795,12 +7941,12 @@ namespace eval punk { append text $linesep\n append text "punk environment vars:\n" append text $linesep\n - set col1 [string repeat " " 25] + 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)] + set c2 [overtype::left $col2 [set ::env($v)]] } else { set c2 [overtype::right $col2 "(NOT SET)"] } @@ -7816,27 +7962,33 @@ namespace eval punk { set indent [string repeat " " [string length "WARNING: "]] lappend cstring_tests [dict create\ type "PM "\ - msg "PRIVACY MESSAGE"\ + msg "UN"\ f7 punk::ansi::controlstring_PM\ - f7desc "7bit ESC ^"\ + f7prefix "7bit ESC ^ secret "\ + f7suffix "safe"\ f8 punk::ansi::controlstring_PM8\ - f8desc "8bit \\x9e"\ + f8prefix "8bit \\x9e secret "\ + f8suffix "safe"\ ] lappend cstring_tests [dict create\ type SOS\ - msg "STRING"\ + msg "NOT"\ f7 punk::ansi::controlstring_SOS\ - f7desc "7bit ESC X"\ + f7prefix "7bit ESC X string "\ + f7suffix " hidden"\ f8 punk::ansi::controlstring_SOS8\ - f8desc "8bit \\x98"\ + f8prefix "8bit \\x98 string "\ + f8suffix " hidden"\ ] lappend cstring_tests [dict create\ type APC\ - msg "APPLICATION PROGRAM COMMAND"\ + msg "NOT"\ f7 punk::ansi::controlstring_APC\ - f7desc "7bit ESC _"\ + f7prefix "7bit ESC _ APPLICATION PROGRAM COMMAND "\ + f7suffix " hidden"\ f8 punk::ansi::controlstring_APC8\ - f8desc "8bit \\x9f"\ + f8prefix "8bit \\x9f APPLICATION PROGRAM COMMAND "\ + f8suffix " hidden"\ ] foreach test $cstring_tests { @@ -7846,14 +7998,14 @@ namespace eval punk { 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 f7desc] [a red]${m}[a]" + 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 f7desc] [a red]$m[a]" + 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 f8desc] [a red]$m8[a]" + 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 f8desc] [a red]$m8[a]" + 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" } @@ -7923,7 +8075,7 @@ namespace eval punk { } set widest0 [$t column_datawidth 0] $t configure_column 0 -minwidth [expr {$widest0 + 4}] - append text \n[$t print] + append text \n[$t print] lappend chunks [list stdout $text] } @@ -7933,7 +8085,7 @@ namespace eval punk { proc help {args} { set chunks [help_chunks {*}$args] foreach chunk $chunks { - lassign $chunk chan text + lassign $chunk chan text puts -nonewline $chan $text } } @@ -7963,8 +8115,7 @@ namespace eval punk { interp alias {} know {} punk::know interp alias {} know? {} punk::know? - #interp alias {} arg {} punk::val - interp alias {} val {} punk::val + #interp alias {} val {} punk::val interp alias {} exitcode {} punk::exitcode interp alias {} hide {} punkapp::hide_console ;#will only work if controllable toplevels exist @@ -7979,7 +8130,7 @@ namespace eval punk { - + #friendly sh aliases (which user may wish to disable e.g if conflicts) interp alias {} test {} punk::sh_test ;#not much reason to run 'test' directly in punk shell (or tclsh shell) as returncode not obvious anyway due to use of exec interp alias {} TEST {} punk::sh_TEST; #double-evaluation to return tcl true/false from exitcode @@ -8016,7 +8167,7 @@ namespace eval punk { #---------------------------------------------- interp alias {} linelistraw {} punk::linelistraw - + # 'path' collides with kettle path in kettle::doc function - todo - patch kettle? interp alias {} PATH {} punk::path @@ -8066,13 +8217,13 @@ namespace eval punk { # 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 {} 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 {} lw {} ls -aFv --color=always interp alias {} dir {} shellrun::runconsole dir @@ -8093,7 +8244,7 @@ namespace eval punk { interp alias {} ./~ {} punk::nav::fs::d/~ interp alias {} d/~ {} punk::nav::fs::d/~ interp alias "" x/ "" punk::nav::fs::x/ - + if {$::tcl_platform(platform) eq "windows"} { set has_powershell 1 @@ -8101,10 +8252,10 @@ namespace eval punk { interp alias {} dw {} dir /W/D } else { #todo - natsorted equivalent - #interp alias {} dl {} + #interp alias {} dl {} interp alias {} dl {} puts stderr "not implemented" interp alias {} dw {} puts stderr "not implemented" - #todo - powershell detection on other platforms + #todo - powershell detection on other platforms set has_powershell 0 } if {$has_powershell} { @@ -8142,7 +8293,7 @@ namespace eval punk { 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]} { @@ -8167,8 +8318,8 @@ 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! +punk::mix::cli set_alias dev +punk::mix::cli set_alias deck ;#deprecate! #todo - add punk::deck for managing cli modules and commandsets diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm index 5b45b2bc..b8fada0b 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -103,7 +103,9 @@ tcl::namespace::eval punk::aliascore { #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 must be in export list of their source namespace + #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\ @@ -116,14 +118,15 @@ tcl::namespace::eval punk::aliascore { 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\ - ansi ::punk::console::ansi\ color ::punk::console::colour\ + ansi ::punk::console::ansi\ a? ::punk::console::code_a?\ A? {::punk::console::code_a? forcecolor}\ a+ ::punk::console::code_a+\ @@ -132,6 +135,9 @@ tcl::namespace::eval punk::aliascore { 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 @@ -153,6 +159,35 @@ tcl::namespace::eval punk::aliascore { # 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} @@ -195,6 +230,7 @@ tcl::namespace::eval punk::aliascore { 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" @@ -206,16 +242,36 @@ tcl::namespace::eval punk::aliascore { } else { if {[tcl::info::commands $cmd] ne ""} { #todo - ensure exported? noclobber? - if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} { + 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" - tcl::namespace::eval :: [list namespace import $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)" - tcl::namespace::eval $tempns [list namespace import $cmd] - catch {rename ${tempns}::[namespace tail $cmd] ::$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 @@ -223,7 +279,7 @@ tcl::namespace::eval punk::aliascore { } } #tcl::namespace::delete $tempns - return [dict create aliases [dict keys $aliases] unchanged $ignore_aliases changed $conflicts] + return [dict create aliases [dict keys $aliases] existing $existing ignored $ignore_aliases changed $conflicts failed $failed] } diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index 9b8c7619..255715ad 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -611,7 +611,7 @@ tcl::namespace::eval punk::ansi { } ""] proc example {args} { - set argd [punk::args::get_by_id ::punk::ansi::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" @@ -723,7 +723,8 @@ tcl::namespace::eval punk::ansi { } lappend adjusted_row $i } - append result [textblock::join_basic -- {*}$adjusted_row] \n + #append result [textblock::join_basic -- {*}$adjusted_row] \n + append result [textblock::join_basic_raw {*}$adjusted_row] \n incr rowindex } @@ -876,6 +877,7 @@ tcl::namespace::eval punk::ansi { tlc l\ trc k\ blc m\ + brc j\ ltj t\ rtj u\ ttj w\ @@ -985,51 +987,51 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #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 + 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 + 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 + 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 + 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 @@ -1041,7 +1043,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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 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 # -- --- --- @@ -1068,7 +1070,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #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 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 @@ -1089,10 +1091,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #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 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 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 @@ -1113,7 +1115,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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 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 @@ -1126,11 +1128,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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 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 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 @@ -1160,15 +1162,15 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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 + 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 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 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 @@ -1201,6 +1203,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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: @@ -1217,6 +1223,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #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. @@ -1612,7 +1619,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set fg "black" } } - lappend clist "[a+ {*}$fc {*}$fg Term$i][format %3s $i]" + lappend clist "[a+ {*}$fc {*}$fg Term-$i][format %3s $i]" } set t [textblock::list_as_table -columns 36 -return tableobject $clist] @@ -1636,7 +1643,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu if {$i > 8} { set fg "web-black" } - append out "[a+ {*}$fc {*}$fg Term$i][format %3s $i] " + append out "[a+ {*}$fc {*}$fg Term-$i][format %3s $i] " } return $out[a] } @@ -1698,7 +1705,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } else { set br "" } - append out "$br[a+ {*}$fc {*}$fg Term$i][format %3s $i] " + append out "$br[a+ {*}$fc {*}$fg Term-$i][format %3s $i] " } append out [a] return [tcl::string::trimleft $out \n] @@ -1723,7 +1730,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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 + 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] @@ -1792,7 +1799,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu foreach cnum $pastel8 { append p8 "[a+ {*}$fc $fg Term-$cnum][format %3s $cnum] " } - append p8 [a]\n + #append p8 [a]\n + #append out \n $p8 + + append p8 [a] append out \n $p8 return $out @@ -1879,7 +1889,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu if {$i > 243} { set fg "web-black" } - append out "[a+ {*}$fc {*}$fg Term$i][format %3s $i] " + append out "[a+ {*}$fc {*}$fg Term-$i][format %3s $i] " } return $out[a] @@ -1899,7 +1909,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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 + 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] @@ -1919,6 +1929,169 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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\ @@ -1970,17 +2143,17 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } 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\ - ] + #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 @@ -1988,11 +2161,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu $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] - if {$cname in $white_fg_list} { - set fg "web-white" - } else { - set fg "web-black" - } + 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] } @@ -2083,12 +2257,66 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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 @@ -2172,6 +2400,20 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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 @@ -2191,40 +2433,74 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } else { switch -- [lindex $args 0] { term { - set termargs [lrange $args 1 end] - foreach ta $termargs { - switch -- $ta { - pastel - rainbow {} - default {error "unrecognised term option '$ta'. Known values: pastel rainbow"} - } - } - set out "16 basic colours\n" - append out [colourtable_16_names -forcecolour $opt_forcecolour] \n - append out "216 colours\n" - append out [colourtable_216_names -forcecolour $opt_forcecolour] \n - append out "24 greyscale colours\n" - append out [colourtable_24_names -forcecolour $opt_forcecolour] - foreach ta $termargs { - switch -- $ta { + 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 \n append out "Pastel Colour Space (punk::ansi::colourtable_term_pastel)\n" - append out [colourtable_term_pastel -forcecolour $opt_forcecolour] + append out [colourtable_term_pastel -forcecolour $opt_forcecolour] \n } rainbow { - append out \n append out "Rainbow Colours (punk::ansi::colourtable_term_rainbow)\n" - append out [colourtable_term_rainbow -forcecolour $opt_forcecolour] + 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)" } } } - 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" return $out } web { - return [colourtable_web -forcecolour $opt_forcecolour -groups [lrange $args 1 end]] + 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] @@ -2243,10 +2519,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set resultlist [list] foreach i $args { - set f4 [tcl::string::range $i 0 3] + #set f4 [tcl::string::range $i 0 3] + set pfx [lindex [::split $i "-# "] 0] set s [a+ {*}$fc $i]sample - switch -- $f4 { - web- - Web- - WEB- { + 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 { @@ -2275,7 +2552,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu $t add_row [list $i $descr $s [ansistring VIEW $s]] } term - Term - undt { - set tail [tcl::string::trim [tcl::string::range $i 4 end] -] + 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]" @@ -2292,10 +2569,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } $t add_row [list $i $descr $s [ansistring VIEW $s]] } - x11- - X11- { - set tail [tcl::string::tolower [tcl::string::trim [tcl::string::range $i 4 end] -]] - if {[tcl::dict::exists $X11_colour_map $tail]} { - set dec [tcl::dict::get $X11_colour_map $tail] + 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 { @@ -2303,12 +2583,27 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } $t add_row [list $i $descr $s [ansistring VIEW $s]] } - rgb- - Rgb- - RGB- - - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 - - rgb# - Rgb# - RGB# - - und# - und- { + 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 { @@ -2339,7 +2634,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } set info "$hexfinal $decfinal" ;#show opposite type as first line of info col } else { - set tail [tcl::string::trim [tcl::string::range $iplain 3 end] -] + set tail [tcl::string::range $iplain 4 end] set dec $tail switch -- $cont { -contrasting { @@ -2369,15 +2664,23 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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]] } - unde { + default { switch -- $i { undercurly - undercurl - underdotted - underdot - underdashed - underdash - undersingle - underdouble { $t add_row [list $i extended $s [ansistring VIEW $s]] @@ -2389,19 +2692,17 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu $t add_row [list $i "SGR 59" $s [ansistring VIEW $s]] } default { - $t add_row [list $i UNKNOWN $s [ansistring VIEW $s]] - } - } - } - default { - 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]] + #$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]] + } + } } } } @@ -2469,7 +2770,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } if {$pretty} { #return [pdict -channel none sgr_cache */%str,%ansiview] - return [pdict -channel none sgr_cache */%rpadstr-"sample",%ansiviewstyle] + return [punk::lib::pdict -channel none sgr_cache */%rpadstr-"sample",%ansiviewstyle] } if {[catch { @@ -2541,24 +2842,19 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set t [list] set e [list] ;#extended codes needing to go in own escape sequence foreach i $args { - set f4 [tcl::string::range $i 0 3] - switch -- $f4 { - web- { + 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 tail [tcl::string::tolower [tcl::string::range $i 4 end]] + set cname [tcl::string::tolower [tcl::string::range $i 4 end]] #-contrasting #-contrastive - set cont [string range $tail end-11 end] - switch -- $cont { - -contrasting - -contrastive { - set cname [string range $tail 0 end-12] - } - default { - set cname $tail - } - } + 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 { @@ -2577,7 +2873,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu puts stderr "ansi web colour unmatched: '$i' in call 'a+ $args'" } } - Web- - WEB- { + Web - WEB { #variable WEB_colour_map #upvar ::punk::ansi::WEB_colour_map WEB_colour_map #background web colour @@ -2609,140 +2905,94 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu puts stderr "ansi Web colour unmatched: '$i' in call 'a+ $args'" } } - rese {lappend t 0 ;#reset} + reset {lappend t 0} bold {lappend t 1} dim {lappend t 2} - blin { - #blink - lappend t 5 - } - fast { - #fastblink - lappend t 6 - } - nobl { - #noblink - lappend t 25 - } + blink {lappend t 5} + fastblink {lappend t 6 } + noblink {lappend t 25} hide {lappend t 8} - norm {lappend t 22 ;#normal} - unde { - #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 - switch -- $i { - underline { - lappend t 4 ;#underline - } - 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 { - lappend e 4:5 - } - default { - puts stderr "ansi term unmatched: unde* '$i' in call 'a $args' (underline,undersingle,underdouble,undercurly,underdotted,underdashed)" - } - } - } - doub {lappend t 21 ;#doubleunderline} - noun { + 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 } - stri {lappend t 9 ;#strike} - nost {lappend t 29 ;#nostrike} - ital {lappend t 3 ;#italic} - noit {lappend t 23 ;#noitalic} - reve {lappend t 7 ;#reverse} - nore {lappend t 27 ;#noreverse} - defa { - switch -- $i { - defaultfg { - lappend t 39 - } - defaultbg { - lappend t 49 - } - defaultund { - lappend t 59 - } - default { - puts stderr "ansi term unmatched: defa* '$i' in call 'a $args' (defaultfg,defaultbg,defaultund)" - } - } - } - nohi {lappend t 28 ;#nohide} - over {lappend t 53 ;#overline} - noov {lappend t 55 ;#nooverline} - fram { - if {$i eq "frame"} { - lappend t 51 ;#frame - } else { - lappend t 52 ;#framecircle - } - } - nofr {lappend t 54 ;#noframe} - blac {lappend t 30 ;#black} + 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} - gree {lappend t 32 ;#green} - yell {lappend t 33 ;#yellow} + green {lappend t 32} + yellow {lappend t 33} blue {lappend t 34} - purp {lappend t 35 ;#purple} + purple {lappend t 35} cyan {lappend t 36} - whit {lappend t 37 ;#white} - Blac {lappend t 40 ;#Black} + white {lappend t 37} + Black {lappend t 40} Red {lappend t 41} - Gree {lappend t 42 ;#Green} - Yell {lappend t 43 ;#Yellow} + Green {lappend t 42} + Yellow {lappend t 43} Blue {lappend t 44} - Purp {lappend t 45 ;#Purple} + Purple {lappend t 45} Cyan {lappend t 46} - Whit {lappend t 47 ;#White} - brig { - switch -- $i { - 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} - } - } - Brig { - switch -- $i { - 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} - } - } + 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 @@ -2772,105 +3022,112 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } } - rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - - Rgb- - RGB- - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 { - #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] + 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 + } } - 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 {;}] + } } - } - set rgbspec [tcl::string::trim [tcl::string::range $iplain 3 end] -] - set RGB [tcl::string::map [list - { } , { } {;} { }] $rgbspec] ;#RGB as list - switch -- $cont { - -contrasting { - set rgbfinal [join [punk::ansi::colour::contrasting {*}$RGB] {;}] + if {[tcl::string::index $i 0] eq "r"} { + #fg + lappend t "38;2;$rgbfinal" + } else { + #bg + lappend t "48;2;$rgbfinal" } - -contrastive { - set rgbfinal [join [lindex [punk::ansi::colour::contrast_pair {*}$RGB] 0] {;}] + + } 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 {;}] + } } - 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" } - } - if {[tcl::string::index $i 0] eq "r"} { - #fg - lappend t "38;2;$rgbfinal" } else { - #bg - lappend t "48;2;$rgbfinal" + puts stderr "punk::ansi::a+ ansi term rgb colour unmatched: '$i' in call 'a+ $args'" } } - "rgb#" - "Rgb#" - "RGB#" { - set hex6 [tcl::string::trim [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] {;}] + 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 {:}] + } } - 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 {:}] + } } - } - if {[tcl::string::index $i 0] eq "r"} { - #hex rgb foreground - lappend t "38;2;$rgbfinal" + lappend e "58:2::$rgbfinal" } else { - #hex rgb background - lappend t "48;2;$rgbfinal" - } - } - und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 { - #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::trim [tcl::string::range $i 3 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 {:}] - } + puts stderr "punk::ansi::a+ ansi term underline colour unmatched: '$i' in call 'a+ $args'" } - #lappend e "58:2:$rgbfinal" ;# - no colorspace ID - some terminals support? which? - lappend e "58:2::$rgbfinal" - } - "und#" { - #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators - set hex6 [tcl::string::trim [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" } undt { #CSI 58:5 UNDERLINE COLOR PALETTE INDEX @@ -2878,7 +3135,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #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::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] + 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 { @@ -2889,7 +3146,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } } - x11- { + x11 { variable X11_colour_map #foreground X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] @@ -2898,10 +3155,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "38;2;$rgb" } else { - puts stderr "ansi x11 colour unmatched: '$i' in call 'a+ $args'" + puts stderr "ansi x11 foreground colour unmatched: '$i' in call 'a+ $args'" } } - X11- { + X11 { variable X11_colour_map #background X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] @@ -2910,7 +3167,59 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "48;2;$rgb" } else { - puts stderr "ansi X11 colour unmatched: '$i'" + 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 { @@ -2919,7 +3228,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } elseif {[tcl::string::first : $i] > 0} { lappend e $i } else { - puts stderr "ansi name unmatched: '$i' in call 'a+ $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-" + puts stderr "punk::ansi::a+ ansi name unmatched: '$i' in call 'a+ $args' Perhaps missing prefix? e.g web- x11- tk- term- rgb# rgb-" } } } @@ -2974,6 +3283,32 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #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\ @@ -2981,28 +3316,25 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu Unlike punk::ansi::a - it is not prefixed with an ANSI reset. " @values -min 0 -max -1 - } [string map [list [dict keys $SGR_map] $SGR_samples] { - code -type string -optional 1 -multiple 1 -choices {}\ - -choicelabels {}\ + } [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 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 - 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 - web- Web- - - The acceptable values for and can be queried using - punk::ansi::a? term - and - punk::ansi::a? web - - Example to set foreground red and background cyan followed by a reset: - set str \"[a+ red Cyan]sample text[a]\" + "%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} { @@ -3027,6 +3359,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #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 @@ -3044,9 +3377,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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] - switch -- $f4 { - web- { + #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 @@ -3059,7 +3393,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu puts stderr "ansi web colour unmatched: '$i' in call 'a $args'" } } - Web- - WEB- { + Web - WEB { #variable WEB_colour_map #upvar ::punk::ansi::WEB_colour_map WEB_colour_map #background web colour @@ -3070,142 +3404,100 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu puts stderr "ansi Web colour unmatched: '$i' in call 'a $args'" } } - rese {lappend t 0 ;#reset} + reset {lappend t 0} bold {lappend t 1} dim {lappend t 2} - blin { - #blink - lappend t 5 - } - fast { - #fastblink - lappend t 6 - } - nobl { - #noblink - lappend t 25 - } + blink {lappend t 5} + fastblink {lappend t 6} + noblink {lappend t 25} hide {lappend t 8} - norm {lappend t 22 ;#normal} - unde { - switch -- $i { - 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 - } - default { - puts stderr "ansi term unmatched: unde* '$i' in call 'a $args' (underline,undersingle,underdouble,undercurly,underdotted,underdashed)" - } - } - } - doub {lappend t 21 ;#doubleunderline} - noun { + 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 } - stri {lappend t 9 ;#strike} - nost {lappend t 29 ;#nostrike} - ital {lappend t 3 ;#italic} - noit {lappend t 23 ;#noitalic} - reve {lappend t 7 ;#reverse} - nore {lappend t 27 ;#noreverse} - defa { - switch -- $i { - defaultfg { - lappend t 39 - } - defaultbg { - lappend t 49 - } - defaultund { - lappend t 59 - } - default { - puts stderr "ansi term unmatched: defa* '$i' in call 'a $args' (defaultfg,defaultbg,defaultund)" - } - } - } - nohi {lappend t 28 ;#nohide} - over {lappend t 53 ;#overline} - noov {lappend t 55 ;#nooverline} - fram { - if {$i eq "frame"} { - lappend t 51 ;#frame - } else { - lappend t 52 ;#framecircle - } - } - nofr {lappend t 54 ;#noframe} - blac {lappend t 30 ;#black} + 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} - gree {lappend t 32 ;#green} - yell {lappend t 33 ;#yellow} + green {lappend t 32} + yellow {lappend t 33} blue {lappend t 34} - purp {lappend t 35 ;#purple} + purple {lappend t 35} cyan {lappend t 36} - whit {lappend t 37 ;#white} - Blac {lappend t 40 ;#Black} + white {lappend t 37} + Black {lappend t 40} Red {lappend t 41} - Gree {lappend t 42 ;#Green} - Yell {lappend t 43 ;#Yellow} + Green {lappend t 42} + Yellow {lappend t 43} Blue {lappend t 44} - Purp {lappend t 45 ;#Purple} + Purple {lappend t 45} Cyan {lappend t 46} - Whit {lappend t 47 ;#White} - brig { - switch -- $i { - 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} - } - } - Brig { - switch -- $i { - 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} - } - } + 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]] -] + 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 { @@ -3219,7 +3511,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 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]] -] + 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 { @@ -3230,49 +3522,63 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } } - rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 { - #decimal rgb foreground - #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx - set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] - set rgb [tcl::string::map [list - {;} , {;}] $rgbspec] - lappend t "38;2;$rgb" - } - Rgb- - RGB- - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 { - #decimal rgb background - set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] - set rgb [tcl::string::map [list - {;} , {;}] $rgbspec] - lappend t "48;2;$rgb" - } - "rgb#" { - #hex rgb foreground - set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] - set rgb [join [::scan $hex6 %2X%2X%2X] {;}] - lappend t "38;2;$rgb" - } - "Rgb#" - "RGB#" { - #hex rgb background - set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] - set rgb [join [::scan $hex6 %2X%2X%2X] {;}] - lappend t "48;2;$rgb" - } - und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 { - #decimal rgb underline - #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx - set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] - set rgb [tcl::string::map [list - {:} , {:}] $rgbspec] - lappend e "58:2::$rgb" - } - "und#" { - #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators - set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] - set rgb [join [::scan $hex6 %2X%2X%2X] {:}] - lappend e "58:2::$rgb" + 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 - set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] + #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 { @@ -3283,7 +3589,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } } - x11- { + x11 { variable X11_colour_map #foreground X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] @@ -3292,10 +3598,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "38;2;$rgb" } else { - puts stderr "ansi x11 colour unmatched: '$i'" + puts stderr "ansi x11 foreground colour unmatched: '$i'" } } - X11- { + X11 { variable X11_colour_map #background X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] @@ -3304,7 +3610,31 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "48;2;$rgb" } else { - puts stderr "ansi X11 colour unmatched: '$i'" + 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 { @@ -3313,7 +3643,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } elseif {[tcl::string::first : $i] > 0} { lappend e $i } else { - puts stderr "ansi name unmatched: '$i' in call 'a $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-" + puts stderr "punk::ansi::a ansi name unmatched: '$i' in call 'a $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-" } } } @@ -3356,10 +3686,24 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend PUNKARGS [list { @id -id ::punk::ansi::ansiwrap - @cmd -name punk::ansi::ansiwrap -help\ - "Wrap a string with ANSI codes from + @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. + 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 @@ -3372,41 +3716,287 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu For finer control use the a+ and a functions eg - set x \"[a+ red]text [a+ bold]etc[a]\" - " + 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 string -help\ + text -type any -help\ "String to wrap with ANSI (SGR)" }] - #proc ansiwrap {codes text} { - # return [a {*}$codes]$text[a] - #} - proc ansiwrap2 {args} { - set argd [punk::args::parse $args withid ::punk::ansi::ansiwrap] - set codelists [dict get $argd leaders codelist] - set text [dict get $argd values text] - set codes [concat {*}$codelists] ;#flatten - return [a {*}$codes]$text[a] - } proc ansiwrap {args} { if {[llength $args] < 1} { - #minimal args parsing - unhappy path only + #throw to args::parse to get friendly error/usage display punk::args::parse $args withid ::punk::ansi::ansiwrap return } - set text [lindex $args end] - set codelists [lrange $args 0 end-1] + #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 - return [a {*}$codes]$text[a] + 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::detect $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::detect $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 @@ -4331,6 +4921,20 @@ to 223 (=255 - 32) } #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] ] @@ -4491,6 +5095,77 @@ tcl::namespace::eval punk::ansi { 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} @@ -4513,6 +5188,7 @@ tcl::namespace::eval punk::ansi { 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 @@ -4626,6 +5302,15 @@ tcl::namespace::eval punk::ansi { #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 { @@ -5782,6 +6467,8 @@ tcl::namespace::eval punk::ansi::class { 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] @@ -7355,7 +8042,7 @@ tcl::namespace::eval punk::ansi::ansistring { #return pair of column extents occupied by the character index supplied. #single-width grapheme will return pair of integers of equal value - #doulbe-width grapheme will return a pair of consecutive indices + #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] @@ -7524,6 +8211,31 @@ namespace eval punk::ansi::colour { } 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 diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm new file mode 100644 index 00000000..6e8e28e4 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/ansi/colourmap-0.1.0.tm @@ -0,0 +1,966 @@ +# -*- 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/vendor/punk/project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm deleted file mode 100644 index 91f29aa5..00000000 --- a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm +++ /dev/null @@ -1,5314 +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.1.0 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.1.0] -#[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::get_dict is made near the beginning of the proc with a cacheable first argument defining the parameters e.g -#[example { -# proc dofilestuff {args} { -# lassign [dict values [punk::args::get_dict { -# @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 -# } $args]] 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 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 call above may be something like: -#[para] 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 -#[example { -# proc dofilestuff {category args} { -# lassign [dict values [punk::args::get_dict { -# -directory -default "" -# -translation -default binary -# -nocomplain -type none -# @values -min 2 -max 2 -# fileA -type existingfile 1 -# fileB -type existingfile 1 -# } $args]] 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::get_dict { -# category -choices {cat1 cat2 cat3} -# another_leading_arg -type boolean -# } [list $category $another_leading_arg] -#}] - -#*** !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}] - #[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 [list] ;#fully loaded - variable loaded_info [dict create] ;#time - variable scanned_packages [list] ;#packages scanned for ids used to update namespace_docpackages - variable scanned_info [dict create] ;#time and idcount - #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 [dict create] - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::args::register ---}] -} - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# 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 [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} - variable id_cache_rawdef [tcl::dict::create] - variable id_cache_spec [tcl::dict::create] - - variable 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 [tcl::dict::create] - - variable 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 %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. - Returns a dictionary representing the argument specifications. - - The return result can generally be ignored, as the record is stored keyed on the - @id -id value from the supplied definition. - 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 ... - - 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 begginning 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 and help display. - directives include: - %B%@id%N% ?opt val...? - spec-options: -id - %B%@cmd%N% ?opt val...? - spec-options: -name -help - %B%@leaders%N% ?opt val...? - spec-options: -min -max - (used for leading args that come before switches/opts) - %B%@opts%N% ?opt val...? - spec-options: -any - %B%@values%N% ?opt val...? - spec-options: -min -max - (used for trailing args that come after switches/opts) - %B%@argdisplay%N% ?opt val...? - spec-options: -header (text for header row of table) - -body (text to replace autogenerated arg info) - %B%@doc%N% ?opt val...? - spec-options: -name -url - %B%@seealso%N% ?opt val...? - spec-options: -name -url (for footer - unimplemented) - - Some other spec-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 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 - defaults to string. If no other restrictions - are specified, choosing string does the least validation. - recognised types: - none - (used for switches only. Indicates this is - a 'solo' flag ie accepts no value) - int|integer - list - dict - double - bool|boolean - char - file - directory - string - ansistring - globstring - (any of the types accepted by 'string is') - - These all perform some validation checks - - and more.. (todo - document here) - - -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. - -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. - -choicegroups {} - Generally this would be used instead of -choices to allow - usage display of choices grouped by some name. - 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. - -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) - - - " - -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 -type string -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 - definition { - @id -id ::myns::myfunc - @cmd -name myns::myfunc -help\\ - \"Description of command\" - - #The following option defines an option-value pair - -option1 -default blah -type string - #The following option defines a flag style option (solo) - -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 - #Items that don't begin with * or - are value definitions - 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 leaderspec_defaults [tcl::dict::create\ - -type string\ - -optional 0\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set optspec_defaults [tcl::dict::create\ - -type string\ - -optional 1\ - -allow_ansi 1\ - -validate_ansistripped 0\ - -strip_ansi 0\ - -nocase 0\ - -choiceprefix 1\ - -choicerestricted 1\ - -choicemultiple {1 1}\ - -multiple 0\ - -regexprepass {}\ - -validationtransform {}\ - ] - set valspec_defaults [tcl::dict::create\ - -type string\ - -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 {}\ - LEADER_NAMES {}\ - LEADER_MIN ""\ - LEADER_MAX ""\ - leaderspec_defaults $leaderspec_defaults\ - LEADER_CHECKS_DEFAULTS {}\ - opt_default {}\ - opt_required {}\ - OPT_NAMES {}\ - opt_any {}\ - opt_solos {}\ - optspec_defaults $optspec_defaults\ - OPT_CHECKS_DEFAULTS {}\ - val_defaults {}\ - val_required {}\ - VAL_NAMES {}\ - val_min ""\ - val_max ""\ - valspec_defaults $valspec_defaults\ - VAL_CHECKS_DEFAULTS {}\ - argdisplay_info ""\ - ] - - #set argdata_dict [tcl::dict::create\ - # id $DEF_definition_id\ - # arg_info $arg_info\ - # arg_checks $arg_checks\ - # leader_defaults $leader_defaults\ - # leader_required $leader_required\ - # leader_names $leader_names\ - # leader_min $leader_min\ - # leader_max $leader_max\ - # leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ - # leader_checks_defaults $leader_checks_defaults\ - # opt_defaults $opt_defaults\ - # opt_required $opt_required\ - # opt_names $opt_names\ - # opt_any $opt_any\ - # opt_solos $opt_solos\ - # optspec_defaults [dict get $F $firstformid optspec_defaults]\ - # opt_checks_defaults $opt_checks_defaults\ - # val_defaults $val_defaults\ - # val_required $val_required\ - # val_names $val_names\ - # val_min $val_min\ - # val_max $val_max\ - # valspec_defaults [dict get $F $firstformid valspec_defaults]\ - # val_checks_defaults $val_checks_defaults\ - # cmd_info $cmd_info\ - # doc_info $doc_info\ - # argdisplay_info $argdisplay_info\ - # id_info $id_info\ - # form_defs $F\ - #] - } - proc define {args} { - dict get [resolve {*}$args] id - } - proc resolve {args} { - variable rawdef_cache - variable id_cache_rawdef - if {[dict exists $rawdef_cache $args]} { - set id [dict get $rawdef_cache $args -id] - set is_dynamic [dict get $rawdef_cache $args -dynamic] - } else { - set id [rawdef_id $args] - 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) - #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] - } - - 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} { - set optionspecs [uplevel 1 [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - } - } else { - #we are always doing our first subst during the define.. shouldn't it be a separate resolve somehow? optionally so at least? - - 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 1 [list ::subst $param]] - } - } else { - set normargs [list] - foreach a $textargs { - lappend normargs [tcl::string::map {\r\n \n} $a] - } - set optionspecs [join $normargs \n] - #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 1 [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 $optionspecs]} { - #resolved cache version exists - return [tcl::dict::get $argdata_cache $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_required [list] - set val_required [list] - - 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 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::define - 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::define @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 { - #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 - #todo argdisplay_info by fid - if {![dict size $argdisplay_info]} { - set argdisplay_info [dict get $copyfrom argdisplay_info] - } - #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. - #aim to produce a table/subtable for each - # @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 - - #can we generate a form synopsis if -synopsis not supplied? - - #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 - set cmd_info [dict merge $cmd_info $at_specs] - } - doc { - set doc_info [dict merge $doc_info $at_specs] - } - argdisplay { - #override the displayed argument table. - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing - set argdisplay_info [dict merge $argdisplay_info $at_specs] - } - opts { - foreach fid $record_form_ids { - if {[dict get $F $fid argspace] eq "values"} { - error "punk::args::define - @opts declaration must come before @values (in command form: '$fid') - received '$record_values' id:$DEF_definition_id" - } - dict set F $fid argspace "options" - set tmp_optspec_defaults [dict get $F $fid optspec_defaults] - - foreach {k v} $at_specs { - switch -- $k { - -any - - -anyopts { - set opt_any $v - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceinfo - -choiceprefix - -choiceprefixdenylist - -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 { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - none - "" - - - any - ansistring - globstring - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_optspec_defaults -type $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - #allow overriding of defaults for options that occur later - tcl::dict::set tmp_optspec_defaults $k $v - } - default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - unrecognised key '$k' in @opts line. Known keys: $known id:$DEF_definition_id" - } - } - } - 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::define - @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 { - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - 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::define - 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 - } - -minsize - -maxsize - -range - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { - #review - only apply to certain types? - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -choiceinfo { - if {[llength $v] %2 != 0} { - error "punk::args::define - key '-choiceinfo' 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 { - switch -- $v { - int - integer { - set v int - } - char - character { - set v char - } - bool - boolean { - set v bool - } - dict - dictionary { - set v dict - } - list { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_leaderspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_leaderspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - 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 { - } - -min - - -minvalues { - if {$v < 0} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$DEF_definition_id" - } - set val_min $v - } - -max - - -maxvalues { - if {$v < -1} { - error "punk::args::define - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$DEF_definition_id" - } - set val_max $v - } - -minsize - -maxsize - -range - -choices - -choicemultiple - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -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::define - 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 { - - } - default { - #todo - disallow unknown types unless prefixed with custom- - } - } - tcl::dict::set tmp_valspec_defaults $k $v - } - -optional - - -allow_ansi - - -validate_ansistripped - - -strip_ansi - - -regexprepass - - -regexprefail - - -regexprefailmsg - - -validationtransform - - -multiple { - tcl::dict::set tmp_valspec_defaults $k $v - } - default { - set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range\ - -choices -choicegroups -choicemultiple -choicecolumns -choicelabels -choiceinfo -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase\ - -nominsize -nomaxsize -norange -nochoices -nochoicelabels\ - -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - } - error "punk::args::define - 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] - } - default { - error "punk::args::define - unrecognised @ line in '$rec'. Expected @id @cmd @form... @leaders @opts @values @doc @argdisplay - use @@name if paramname needs to be @name @id:$DEF_definition_id" - } - } - #record_type directive - continue - } elseif {$firstchar eq "-"} { - set argname $firstword - set argdef_values $record_values - tcl::dict::set argdef_values -ARGTYPE option - - - - 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::define - 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] - #lappend 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 { - error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" - } - - if {[dict get $F $fid LEADER_MAX] >= 0} { - 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] - lappend temp_valnames $argname - tcl::dict::set F $fid VAL_NAMES $temp_valnames - #lappend val_names $argname - } - } - - set is_opt 0 - } - - - #assert - we only get here if it is a 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 { - #normalize here so we don't have to test during actual args parsing in main function - switch -- [tcl::string::tolower $specval] { - int - integer { - tcl::dict::set spec_merged -type int - } - bool - boolean { - tcl::dict::set spec_merged -type bool - } - char - character { - tcl::dict::set spec_merged -type char - } - dict - dictionary { - tcl::dict::set spec_merged -type dict - } - "" - none { - if {$is_opt} { - tcl::dict::set spec_merged -type 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. - } - lappend opt_solos $argname - } else { - #-solo only valid for flags - error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" - } - } - any - anything { - tcl::dict::set spec_merged -type any - } - ansi - ansistring { - tcl::dict::set spec_merged -type ansistring - } - any - string - globstring { - tcl::dict::set spec_merged -type [tcl::string::tolower $specval] - } - 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] - } - } - } - -default - -solo - -range - - -choices - -choicegroups - -choicemultiple - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -choiceinfo - - -minsize - -maxsize - -nocase - -optional - -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 - } - -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { - error "punk::args::define - 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 { - -function - -type - -minsize - -maxsize - -range { - } - default { - set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::define - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$DEF_definition_id" - } - } - } - - } - 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::define 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::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" - } - } - } - } else { - set known_argopts [list -form -default -type -range -minsize -maxsize -choices -choicegroups -choicemultiple -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ - -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ - -regexprepass -regexprefail -regexprefailmsg -validationtransform\ - ] - error "punk::args::define - 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] ;#leave things like -range -minsize - } else { - tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#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 {$is_opt} { - lappend opt_required $argname - } 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 - #lappend leader_required $argname - } else { - lappend val_required $argname - } - } - } - if {[tcl::dict::exists $spec_merged -default]} { - if {$is_opt} { - tcl::dict::set 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 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]" - #} - - - #check ALL forms not just form_ids_active (record_form_ids) - dict for {fid formdata} $F { - # 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" - } - } - #confirm any valnames before last don't have -multiple key - foreach valname [lrange [tcl::dict::get $F $fid VAL_NAMES] 0 end-1] { - if {[tcl::dict::get $F $fid ARG_INFO $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname' in command form:'$fid'. Only the last value argument specification can be marked -multiple @id:$DEF_definition_id" - } - } - - #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\ - ARG_INFO [dict get $F $firstformid ARG_INFO]\ - ARG_CHECKS [dict get $F $firstformid ARG_CHECKS]\ - LEADER_DEFAULTS [dict get $F $firstformid LEADER_DEFAULTS]\ - LEADER_REQUIRED [dict get $F $firstformid LEADER_REQUIRED]\ - LEADER_NAMES [dict get $F $firstformid LEADER_NAMES]\ - LEADER_MIN [dict get $F $firstformid LEADER_MIN]\ - LEADER_MAX [dict get $F $firstformid LEADER_MAX]\ - leaderspec_defaults [dict get $F $firstformid leaderspec_defaults]\ - LEADER_CHECKS_DEFAULTS [dict get $F $firstformid LEADER_CHECKS_DEFAULTS]\ - opt_defaults $opt_defaults\ - opt_required $opt_required\ - OPT_NAMES [dict get $F $firstformid OPT_NAMES]\ - opt_any $opt_any\ - opt_solos $opt_solos\ - optspec_defaults [dict get $F $firstformid optspec_defaults]\ - OPT_CHECKS_DEFAULTS [dict get $F $firstformid OPT_CHECKS_DEFAULTS]\ - val_defaults $val_defaults\ - val_required $val_required\ - VAL_NAMES [dict get $F $firstformid VAL_NAMES]\ - val_min $val_min\ - val_max $val_max\ - valspec_defaults [dict get $F $firstformid valspec_defaults]\ - VAL_CHECKS_DEFAULTS [dict get $F $firstformid VAL_CHECKS_DEFAULTS]\ - cmd_info $cmd_info\ - doc_info $doc_info\ - package_info $package_info\ - argdisplay_info $argdisplay_info\ - seealso_info $seealso_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 $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 @argdisplay @seealso @leaders @opts @values leaders opts values} - variable resolved_def_TYPE_CHOICEGROUPS { - directives {@id @package @cmd @ref @doc @argdisplay @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 { - 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] - set included_args [punk::args::system::punklib_ldiff $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 @seealso @argdisplay} { - 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] - } - } - } - #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 $defaults_key] [dict get $opt_override $directive]]" - dict set resultdict $directive [dict merge [dict get $specdict $defaults_key] [dict get $opt_override $directive]] - } else { - append result \n "$directive [dict get $specdict $defaults_key]" - dict set resultdict $directive [dict get $specdict $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 - @seealso - @argdisplay { - 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] - } - } - } - @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 leaderspec_defaults] [dict get $opt_override $type]]" - dict set resultdict $type [dict merge [dict get $specdict leaderspec_defaults] [dict get $opt_override $type]] - } else { - append result \n "$type [dict get $specdict leaderspec_defaults]" - dict set resultdict $type [dict get $specdict leaderspec_defaults] - } - } - } - 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 speclist [tcl::dict::get $id_cache_rawdef $realid] - set specdict [resolve {*}$speclist] - 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 rdef [raw_def $id] - if {$rdef eq ""} {return} - return [resolve {*}$rdef] - #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 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]] - 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 - } - - #scanned_packages (list) - #namespace_docpackages (dict) - proc 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 {$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 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]" - while {[string last \n $cmdinfo] >= 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 - } - } - } - set caller [regexp -inline {\S+} $cmdinfo] - if {$caller eq "namespace"} { - # review - message? - set cmdinfo "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" - -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 laout" - } - -scheme -choices {nocolour info error} - }] ] - - #basic 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::get_dict {@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? - # - - - if {[catch {package require punk::ansi}]} { - proc punk::args::a {args} {} - proc punk::args::a+ {args} {} - } else { - namespace eval ::punk::args { - namespace import ::punk::ansi::a ::punk::ansi::a+ - } - } - #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" - } - - if {[llength $args] %2 != 0} { - error "error in arg_error processing - expected opt/val pairs after msg and spec_dict" - } - - set arg_error_isrunning 1 - - set badarg "" - set returntype table ;#table as string - set as_error 1 ;#usual case is to raise an error - set scheme error - dict for {k v} $args { - set fullk [tcl::prefix::match -error "" {-badarg -aserror -return -scheme} $k] - switch -- $fullk { - -badarg { - set badarg $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 - } - default { - set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -return -aserror" - } - } - } - #todo - scheme - use config and iterm toml definitions etc - switch -- $scheme { - "" - -nocolor - -nocolour { - set scheme nocolour - } - info - error {} - default { - set scheme na - } - } - #hack some basics for now. - #for coloured schemes - use bold as well as brightcolour in case colour off. - array set CLR {} - set CLR(errormsg) [a+ brightred] - set CLR(title) "" - set CLR(check) [a+ brightgreen] - set CLR(solo) [a+ brightcyan] - set CLR(choiceprefix) [a+ underline] - set CLR(badarg) [a+ brightred] - set CLR(linebase_header) [a+ white] - set CLR(cmdname) [a+ brightwhite] - set CLR(groupname) [a+ bold] - set CLR(ansiborder) [a+ bold] - set CLR(ansibase_header) [a+ bold] - set CLR(ansibase_body) [a+ white] - - switch -- $scheme { - nocolour { - set CLR(errormsg) [a+ bold] - set CLR(title) [a+ bold] - set CLR(check) "" - set CLR(solo) "" - set CLR(badarg) [a+ reverse] ;#? experiment - set CLR(cmdname) [a+ bold] - set CLR(linebase_header) "" - set CLR(linebase) "" - set CLR(ansibase_body) "" - } - info { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightyellow bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightcyan bold] - set CLR(ansibase_header) [a+ cyan] - set CLR(ansibase_body) [a+ white] - } - error { - set CLR(errormsg) [a+ brightred bold] - set CLR(title) [a+ brightcyan bold] - set CLR(check) [a+ brightgreen bold] - set CLR(choiceprefix) [a+ brightgreen bold] - set CLR(groupname) [a+ cyan bold] - set CLR(ansiborder) [a+ brightyellow bold] - set CLR(ansibase_header) [a+ yellow] - set CLR(ansibase_body) [a+ white] - } - na { - } - } - - - #set RST [a] - set RST "\x1b\[m" - 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 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 - } - - - 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)] - } 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 "" - set form_info [dict get $spec_dict FORM_INFO] - dict for {fid finfo} $form_info { - set syn [Dict_getdef $finfo -synopsis ""] - if {$syn ne ""} { - append synopsis $syn \n - } - } - if {$synopsis ne ""} { - set synopsis [string range $synopsis 0 end-1] - 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: $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 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 - } else { - set A_PREFIXEND $RST - } - - set opt_names [list] - set opt_names_display [list] - if {[llength [dict get $spec_dict OPT_NAMES]]} { - if {![catch {package require punk::trie}]} { - set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] - set idents [dict get [$trie shortest_idents ""] scanned] - #todo - check opt_prefixdeny - - $trie destroy - foreach c [dict get $spec_dict OPT_NAMES] { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c - } - } else { - set opt_names [dict get $spec_dict OPT_NAMES] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $spec_dict LEADER_NAMES] - set trailing_val_names [dict get $spec_dict VAL_NAMES] - - #dict for {argname info} [tcl::dict::get $spec_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 trailing_val_names_display $trailing_val_names - - #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { - lassign $argumentset argnames_display argnames - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict ARG_INFO $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" - } 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 {}] - 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] - } - 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_test [string tolower $allchoices_originalcase] - } else { - set casemsg " (case sensitive)" - set allchoices_test $allchoices_originalcase - } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" - } else { - set prefixmsg "" - } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - 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 cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } else { - set formattedchoices $choicegroups - #set formattedchoices [dict get $arginfo -choices] - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}$allchoices_test] - 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] - } - 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 cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - 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 cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] - } - dict lappend formattedchoices $groupname $cdisplay - } - } - } else { - set formattedchoices $choicegroups - } - - } - } - 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]] - #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 -range]} { - append typeshow \n "-range [dict get $arginfo -range]" - } - - if {$use_table} { - $t add_row [list $argshow $typeshow $default $multiple $help] - if {$arg eq $badarg} { - $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG - } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - set arghelp "[a+ bold]$argshow$RST TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" - foreach ln [split $help \n] { - append arghelp " $ln" \n - } - lappend errlines $arghelp - } - } - } - } ;#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]} { - catch {$t destroy} - 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" - - } - set arg_error_isrunning 0 - #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 ;) - 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 { - set result $errmsg - } - if {$as_error} { - 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 ::punk::args::arg_error -scheme]}} { - - @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 - set id [dict get $values id] - set real_id [real_id $id] - if {$real_id eq ""} { - error "punk::args::usage - no such id: $id" - } - arg_error "" [punk::args::get_spec $real_id] -scheme punk_info {*}$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" - @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 minimal} - - @values -min 2 - - @form -form withid -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withid $id" - 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} { - set tailtype "" ;#withid|withdef - if {[llength $args] < 3} { - error "punk::args::parse - invalid call. < 3 args" - } - set parseargs [lindex $args 0] - set tailargs [lrange $args 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" - } 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" - } - set defaultopts [dict create\ - -form {*}\ - -errorstyle enhanced\ - ] - set opts [dict merge $opts $defaultopts] - 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]" - } - } - } - switch -- $tailtype { - withid { - if {[llength [lrange $tailargs $split+1 end]] != 1} { - error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" - } - set id [lindex $tailargs $split+1] - #puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts" - set deflist [raw_def $id] - if {[llength $deflist] == 0} { - error "punk::args::parse - no such id: $id" - } - } - withdef { - set deflist [lrange $tailargs $split+1 end] - 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" - } - default { - error "punk::args::parse - invalid call. Argument following arglist must be 'withid' or 'withdef'" - } - } - try { - set result [punk::args::get_dict {*}$deflist $parseargs] - } trap {PUNKARGS} {msg opts} { - #trap punk::args argument validation/parsing errors and decide here - #whether to display basic error - or full usage if configured. - puts stderr "PUNKARGS: $msg\n$opts" - return - } trap {} {msg opts} { - #review - #puts stderr "$msg\n$opts" - #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 $opts -errorcode] [dict get $opts -errorinfo] - return - } - 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 - } - - #todo? - a version of get_dict that directly supports punk::lib::tstr templating - #rename get_dict - # - - #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. - proc get_dict {args} { - #see arg_error regarding considerations around unhappy-path performance - - #consider a better API - # - e.g punk::args::parse ?-flag val?... $arglist withid $id - # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? - #can the above be made completely unambiguous for arbitrary arglist?? - #e.g what if arglist = withdef and the first $def is also withdef ? - - - #*** !doctools - #[call [fun get_dict] [arg optionspecs] [arg rawargs]] - #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values - #[para]Returns a dict of the form: opts values - #[para]ARGUMENTS: - #[list_begin arguments] - #[arg_def multiline-string optionspecs] - #[para] This a block 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 - #[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 { - # @opts - # -opt1 -default {} - # -opt2 -default { - # etc - # } - # @values -multiple 1 - #} $args - - set rawargs [lindex $args end] ;# args values to be parsed - #we take a definition list rather than argspecs - because the definition could be dynamic - set definition_args [lrange $args 0 end-1] - - #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 {*}$definition_args]] - - # ----------------------------------------------- - # Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc) - tcl::dict::with argspecs {} ;#turn keys into vars - # TODO - capitalise 'define' vars to make it a bit easier - # ----------------------------------------------- - - #puts "-arg_info->$arg_info" - set flagsreceived [list] ;#for checking if required flags satisfied - #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 (--) ? - set opts $opt_defaults - set pre_values {} - - set argnames [tcl::dict::keys $ARG_INFO] - set optnames [lsearch -all -inline $argnames -*] - set ridx 0 - set rawargs_copy $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 - if {$LEADER_MAX != 0} { - foreach r $rawargs_copy { - if {$LEADER_MAX ne "" && $LEADER_MAX != -1 && $ridx > $LEADER_MAX-1} { - break - } - if {$ridx == [llength $LEADER_NAMES]-1} { - #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $ridx] - if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 - } - } elseif {$ridx > [llength $LEADER_NAMES]-1} { - #beyond names - retain name if -multiple was true - if {!$is_multiple} { - set leader_posn_name "" - } - } else { - set leader_posn_name [lindex $LEADER_NAMES $ridx] ;#may return empty string - } - if {$r eq "--"} { - #review end of opts marker: '--' can't be a leader (but can be a value) - break - } - - #argument such as a dictionary may have leading dash - test for whitespace to exclude as possible option - if {[tcl::string::match -* $r] && !([tcl::string::first " " $r]>=0 || [tcl::string::first \t $r]>=0 || [tcl::string::last \n $r]>=0)} { - set matchopt [::tcl::prefix::match -error {} $optnames $r] - if {$matchopt ne ""} { - #flaglike matches a known flag - don't treat as leader - break - } - #if {![string match -* [lindex $argnames $ridx]]} {} - if {$leader_posn_name ne ""} { - #there is a named leading positional for this position - #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - incr ridx - continue - } else { - break - } - } - - #for each branch - break or lappend - if {$leader_posn_name ne ""} { - 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] [lindex $rawargs 0]] - # 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 rawargs 0] - # incr ridx - # continue - # } - #} - - #check if enough rawargs to fill any required values - if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { - break - } else { - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #required - if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional - if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { - break - } - } - #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - #unnamed leader - if {$LEADER_MIN ne "" } { - if {$ridx > $LEADER_MIN} { - break - } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop rawargs 0] - dict incr leader_posn_names_assigned $leader_posn_name - } - } else { - break - } - } - - incr ridx - } ;# end foreach r $rawargs_copy - } - - 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 ""} { - set leadermax -1 - } else { - set leadermax $LEADER_MAX - } - - #assert leadermax leadermin are numeric - #assert - rawargs has been reduced by leading positionals - - set leaders [list] - set arglist {} - set post_values {} - #val_min, val_max - #puts stderr "rawargs: $rawargs" - #puts stderr "argstate: $argstate" - if {[lsearch $rawargs -*] >= 0} { - #at least contains flaglike things.. - set maxidx [expr {[llength $rawargs] -1}] - if {$val_max == -1} { - set vals_total_possible [llength $rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $val_max - set vals_remaining_possible $vals_total_possible - } - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $rawargs $i] - set remaining_args_including_this [expr {[llength $rawargs] - $i}] - #lowest val_min is 0 - if {$remaining_args_including_this <= $val_min} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - #exlude argument with whitespace from being a possible option e.g dict - if {[tcl::string::match -* $a] && !([tcl::string::first " " $a]>=0 || [tcl::string::first \t $a]>=0 || [tcl::string::last \n $a]>=0)} { - if {$a eq "--"} { - #remaining num args <= val_min already covered above - if {$val_max != -1} { - #finite max number of vals - if {$remaining_args_including_this == $val_max} { - #assume it's a value. - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - } else { - #assume it's an end-of-options marker - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - } else { - #unlimited number of post_values accepted - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - break - } else { - set fullopt [tcl::prefix match -error "" $OPT_NAMES $a] - if {$fullopt ne ""} { - if {[tcl::dict::get $argstate $fullopt -type] ne "none"} { - #non-solo - #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) - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - set flagval [lindex $rawargs $i+1] - if {[tcl::dict::get $argstate $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - if {$fullopt ni $flagsreceived} { - tcl::dict::set opts $fullopt [list $flagval] - } else { - tcl::dict::lappend opts $fullopt $flagval - } - } else { - tcl::dict::set opts $fullopt $flagval - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $fullopt - } - } else { - #solo - if {[tcl::dict::get $argstate $fullopt -multiple]} { - if {$fullopt ni $flagsreceived} { - #override any default - don't lappend to it - tcl::dict::set opts $fullopt 1 - } else { - tcl::dict::lappend opts $fullopt 1 - } - } else { - tcl::dict::set opts $fullopt 1 - } - incr vals_remaining_possible -1 - } - lappend flagsreceived $fullopt ;#dups ok - } else { - #unmatched option flag - #comparison to val_min already done above - if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding val_max val_min - - #even with 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 $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - if {$opt_any} { - set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option - tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS - if {[tcl::dict::get $argstate $a -type] ne "none"} { - if {[tcl::dict::get $argstate $a -multiple]} { - tcl::dict::lappend opts $a $newval - } else { - tcl::dict::set opts $a $newval - } - if {[incr i] > $maxidx} { - 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::get $argstate $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 - } - } else { - tcl::dict::set opts $a 1 - } - incr vals_remaining_possible -1 - } - lappend flagsreceived $a ;#adhoc flag as supplied - } else { - if {[llength $OPT_NAMES]} { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $OPT_NAMES" - } else { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" - } - arg_error $errmsg $argspecs -badarg $fullopt - } - } - } - } else { - #not flaglike - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $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 $rawargs - #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected - set arglist [list] - } - #puts stderr "--> arglist: $arglist" - #puts stderr "--> values: $values" - - - set positionalidx 0 ;#index for unnamed positionals (both leaders and values) - set ldridx 0 - set in_multiple "" - set leadernames_received [list] - set leaders_dict $LEADER_DEFAULTS - set num_leaders [llength $leaders] - foreach leadername $LEADER_NAMES ldr $leaders { - if {$ldridx+1 > $num_leaders} { - break - } - if {$leadername ne ""} { - if {[tcl::dict::get $argstate $leadername -multiple]} { - if {[tcl::dict::exists $LEADER_DEFAULTS $leadername]} { - tcl::dict::set leaders_dict $leadername [list $ldr] ;#important to treat first element as a list - } else { - tcl::dict::lappend leaders_dict $leadername $ldr - } - set in_multiple $leadername - } else { - tcl::dict::set leaders_dict $leadername $ldr - } - lappend leadernames_received $leadername - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend leaders_dict $in_multiple $ldr - lappend leadernames_received $in_multiple ;#deliberately allow dups! (as with opts and values) - } else { - 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 - } - } - incr ldridx - incr positionalidx - } - - set validx 0 - set in_multiple "" - set valnames_received [list] - set values_dict $val_defaults - set num_values [llength $values] - foreach valname $VAL_NAMES val $values { - if {$validx+1 > $num_values} { - break - } - if {$valname ne ""} { - 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 $val] ;#important to treat first element as a list - } else { - tcl::dict::lappend values_dict $valname $val - } - set in_multiple $valname - } else { - tcl::dict::set values_dict $valname $val - } - lappend valnames_received $valname - } else { - if {$in_multiple ne ""} { - tcl::dict::lappend values_dict $in_multiple $val - #name already seen - but must add to valnames_received anyway (as with opts and leaders) - lappend valnames_received $in_multiple - } else { - 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 - } - } - incr validx - incr positionalidx - } - - if {$leadermax == -1} { - #only check min - if {$num_leaders < $leadermin} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leadermin" $argspecs - } - } else { - if {$num_leaders < $leadermin || $num_leaders > $leadermax} { - if {$leadermin == $leadermax} { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leadermin" $argspecs - } else { - arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leadermin and $leadermax inclusive" $argspecs - } - } - } - - if {$val_max == -1} { - #only check min - if {$num_values < $val_min} { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected at least $val_min" $argspecs - } - } else { - if {$num_values < $val_min || $num_values > $val_max} { - if {$val_min == $val_max} { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected exactly $val_min" $argspecs - } else { - arg_error "bad number of trailing values for [Get_caller]. Got $num_values values. Expected between $val_min and $val_max inclusive" $argspecs - } - } - } - - #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options - - - #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) - #however - if -anyopts 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 [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { - arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { - arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present " $argspecs - } - if {[llength [set missing [punklib_ldiff $val_required $valnames_received]]]} { - arg_error "Required value missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs - } - - - #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 "---opts_and_values:$opts_and_values" - #puts "---argstate:$argstate" - tcl::dict::for {argname v} $opts_and_values { - 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 type [tcl::dict::get $thisarg -type] - set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}] - set regexprepass [tcl::dict::get $thisarg -regexprepass] - set regexprefail [Dict_getdef $thisarg -regexprefail ""] ;#aliased to dict getdef in tcl9 - set validationtransform [tcl::dict::get $thisarg -validationtransform] - - - if {$is_multiple} { - set vlist $v - } else { - set vlist [list $v] - } - 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 e $vlist { - lappend vlist_check [punk::ansi::ansistrip $e] - } - } else { - #validate_ansistripped 0 - set vlist_check $vlist - } - - #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestriction 0 where some selections match and others don't) - if {$has_choices} { - #-choices must also work with -multiple - #todo -choicelabels - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] - 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 - - - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - set dname leaders_dict - } - option { - set dname opts - } - value { - set dname values_dict - } - } - set idx 0 ;# - #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) - set vlist_validate [list] - set vlist_check_validate [list] - foreach e $vlist e_check $vlist_check { - 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 "Option $argname for [Get_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 "Option $argname for [Get_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 v_test $c_check - set choices_test $allchoices - } - 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 { - #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 "" [lsort -unique $allchoices] $c_check] - if {$bestmatch eq ""} { - set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $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 "" [lsort -unique $allchoices] $c_check] - if {$chosen eq ""} { - 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 - if {$choice_in_list && !$choice_exact_match} { - if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { - if {$is_multiple} { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $chosen - tcl::dict::set $dname $argname $existing - } else { - tcl::dict::set $dname $argname $chosen - } - } else { - if {$is_multiple} { - set existing_all [tcl::dict::get [set $dname] $argname] - lset existing_all $idx $choice_idx $chosen - tcl::dict::set $dname $argname $existing_all - } else { - set existing [tcl::dict::get [set $dname] $argname] - lset existing $choice_idx $chosen - tcl::dict::set $dname $argname $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 $idx $v_test - # tcl::dict::set $dname $argname $existing - #} else { - # tcl::dict::set $dname $argname $v_test - #} - 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 "" - } - 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 - } - } - incr choice_idx - } - - incr idx - } - #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 - } - - if {[llength $vlist] && $has_default} { - set vlist_validate [list] - set vlist_check_validate [list] - foreach c $vlist c_check $vlist_check { - #for -choicemultiple with default that could be a list use 'ni' ?? review - if {$c_check ne $defaultval} { - lappend vlist_validate $c - lappend vlist_check_validate $c - } - } - set vlist $vlist_validate - set vlist_check $vlist_check_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 e $vlist { - if {[punk::ansi::ta::detect $e]} { - error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'" - } - } - } - #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]} { - switch -- $type { - any {} - list { - foreach e_check $vlist_check { - if {![tcl::string::is list -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs -badarg $argname - } - 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} { - arg_error "Option $argname for [Get_caller] requires list with -minsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[llength $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires list with -maxsize $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - 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 - if {$regexprepass ne ""} { - foreach e $vlist e_check $vlist_check { - if {[regexp $regexprepass $e]} { - lappend pass_quick_list_e $e - lappend pass_quick_list_e_check $e_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 e $remaining_e e_check $remaining_e_check { - #puts "----> checking $e vs regex $regexprefail" - if {[regexp $regexprefail $e]} { - if {[tcl::dict::exists $thisarg -regexprefailmsg]} { - set msg [tcl::dict::get $thisarg -regexprefailmsg] - } else { - set msg "Option $argname for [Get_caller] didn't pass regexprefail regex: '$regexprefail' got '$e'" - } - arg_error $msg $argspecs -badarg $argname - } - } - } - 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 e $remaining_e { - if {![punk::ansi::ta::detect $e]} { - arg_error "Option $argname for [Get_caller] requires ansistring - but no ansi detected" $argspecs -badarg $argname - } - } - } - globstring { - foreach e $remaining_e { - if {![regexp {[*?\[\]]} $e]} { - arg_error "Option $argname for [Get_caller] requires globstring - but no glob characters detected" $argspecs -badarg $argname - } - } - } - } - - if {[tcl::dict::size $thisarg_checks]} { - foreach e_check $remaining_e_check { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -minsize { - # -1 for disable is as good as zero - if {[tcl::string::length $e_check] < $checkval} { - arg_error "Option $argname for [Get_caller] requires string with -minsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::string::length $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires string with -maxsize $checkval. Received len:[tcl::string::length $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - int { - #-range 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::dict::exists $thisarg -range]} { - lassign [tcl::dict::get $thisarg -range] low high - if {"$low$high" ne ""} { - if {$low eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #lowside unspecified - check only high - if {$e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer less than or equal to $high. Received: '$e'" $argspecs -badarg $argname - } - } - } elseif {$high eq ""} { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #highside unspecified - check only low - if {$e_check < $low} { - arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname - } - } - } else { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname - } - #high and low specified - if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname - } - } - } - } - } else { - foreach e_check $vlist_check { - if {![tcl::string::is integer -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname - } - } - } - } - double { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is double -strict $e_check]} { - error "Option $argname for [Get_caller] requires type 'double'. Received: '$e'" - } - if {[tcl::dict::size $thisarg_checks]} { - #safe jumptable test - #dict for {checkopt checkval} $thisarg_checks {} - tcl::dict::for {checkopt checkval} $thisarg_checks { - switch -- $checkopt { - -range { - #todo - small-value double comparisons with error-margin? review - #todo - empty string for low or high - lassign $checkval low high - if {$e_check < $low || $e_check > $high} { - arg_error "Option $argname for [Get_caller] must be between $low and $high. Received: '$e'" $argspecs -badarg $argname - } - } - } - } - } - } - } - bool { - foreach e_check $vlist_check { - if {![tcl::string::is boolean -strict $e_check]} { - arg_error "Option $argname for [Get_caller] requires type 'boolean'. Received: '$e_check'" $argspecs -badarg $argname - } - } - } - dict { - foreach e_check $vlist_check { - if {[llength $e_check] %2 != 0} { - arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs -badarg $argname - } - 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 {[tcl::dict::size $e_check] < $checkval} { - arg_error "Option $argname for [Get_caller] requires dict with -minsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - -maxsize { - if {$checkval ne "-1"} { - if {[tcl::dict::size $e_check] > $checkval} { - arg_error "Option $argname for [Get_caller] requires dict with -maxsize $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs -badarg $argname - } - } - } - } - } - } - } - } - alnum - - alpha - - ascii - - control - - digit - - graph - - lower - - print - - punct - - space - - upper - - wordchar - - xdigit { - foreach e $vlist e_check $vlist_check { - if {![tcl::string::is $type $e_check]} { - set msg "Option $argname for [Get_caller] requires type '$type'. Received: '$e'" - #try trap? - #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type]]] $result - #throw ? - return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname]] $msg - arg_error $msg $argspecs -badarg $argname - } - } - } - file - - directory - - existingfile - - existingdirectory { - foreach e $vlist e_check $vlist_check { - #//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 ? - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which doesn't look like it could be a file or directory" $argspecs -badarg $argname - } - } - if {$type eq "existingfile"} { - foreach e $vlist e_check $vlist_check { - if {![file exists $e_check]} { - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing file" $argspecs -badarg $argname - } - } - } elseif {$type eq "existingdirectory"} { - foreach e $vlist e_check $vlist_check { - if {![file isdirectory $e_check]} { - arg_error "Option $argname for [Get_caller] requires type '$type'. Received: '$e' which is not an existing directory" $argspecs -badarg $argname - } - } - } - } - char { - foreach e $vlist e_check $vlist_check { - if {[tcl::string::length $e_check] != 1} { - arg_error "Option $argname for [Get_caller] requires type 'character'. Received: '$e' which is not a single character" $argspecs -badarg $argname - } - } - } - } - - } - - 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 $stripped_list - } - option { - tcl::dict::set opts $argname $stripped_list - } - value { - tcl::dict::set values_dict $argname $stripped_list - } - } - } else { - switch -- [tcl::dict::get $thisarg -ARGTYPE] { - leader { - tcl::dict::set leaders_dict [lindex $stripped_list 0] - } - option { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } - value { - tcl::dict::set values_dict [lindex $stripped_list 0] - } - } - } - } - } - - #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 - return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns] - } - - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - - - 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] - - #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] * - } - } - - - #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 -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 { - lappend params [subst -nocommands -novariables $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::get_dict { - @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} - } $args] - 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 - } - - - #*** !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.1.0 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/args-0.2.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/args-0.2.tm new file mode 100644 index 00000000..fc438d57 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/args-0.2.tm @@ -0,0 +1,10284 @@ +# -*- 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 + } + -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 -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 + } + } + -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 -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 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 + } 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]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + } 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/vendor/punk/project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm new file mode 100644 index 00000000..562bddd4 --- /dev/null +++ b/src/project_layouts/vendor/punk/project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm @@ -0,0 +1,6539 @@ +# -*- 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